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FOREWORD 


This final report is submitted to the Atmospheric Sciences Division, 

Space Science Laboratory, Marshall Space Flight Center, in partial fulfill- 
ment of the requirements of Contract No. NAS8-34132. 

This report contains a listing of the REEDM computer program. The program 
was designed for and is operational on Hewlett Packard HPIOOO Multiprogramming 
Systems at the Atmospheric Sciences Division, Space Science Laboratory, NASA/ 
Marshall Space Flight Center; at NASA/Kennedy Space Center; and at H. E. 

Cramer Company, Inc. 

A description of the models, model input parameters, user's instructions 
for the program, and worked example problems are contained in NASA CR-3646 . 

The H. E. Cramer Company, Inc. is indebted to Mr. Joseph C. Sloan and 
Dr. Briscoe Stephens of the Atmospheric Sciences Division at MSFC for technical 
^idance and helpful suggestions in the development of the REEDM program and in 
the design of output formats. Mr. Norman Reavis, Atmospheric Sciences Division, 
MSFC, and Mr. Joseph Parker, KSC, assisted in the implementation of the programs 

at MSFC and KSC. 


REEDM SOURCE MODULE &REEDM 


FTN4 SOIOOOOO 
PROGRAM REEDM(3,200) SOlOOOlO 
. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S0100020 




C S0100040 
C MAIN MODULE OF ROCKET EXHAUST EFFLUENT DIFFUSION ANALYSIS S0100050 
C (MULTI-LAYER) PROGRAM SO 100060 
C S0100070 


C******* **************!*:******?*:************************>!:************* ****30100080 


C S0100090 
C TO REPORT PROGRAM ERRORS - CALL JAY R. BJORKLUND (801) 581-0220 SOlOOlOO 
C H.E. CRAMER CO. INC., SALT LAKE CITY, UTAH. SOlOOllO 
C S0100120 

(]********* A***********;i;*****:ft:J;*A*******A*A:fc****:k*:S: A J;:l!;jt*****«;*A*****:^***:^'5Q]^QQ 2 3Q 

c so 100 140 
C THIS PROGRAM REQUIRES THE PROGRAM SEGMENTS READM, REDAM, RDATM, S0100150 
C RCLDM, RDHMM, RCONM, RCNOM, RPDPM, RGDPM, RGPDM, RCIMM ALONG S0100160 
C WITH THE MAIN REEDM PROGRAM FOR EXECUTION. S0100170 
C S0100180 
C THE REEDM SOURCE PROGRAMS ARE - &REEDM, &READM, &REDAM, &RDATM, 80100190 


C &RCONN, &RPDPM, &RPDPN, &RGDPM, &RGPDM, &RGDPN, &RSUBM, &RCIMM, S0100210 
C AND &RCIMN. S0100220 
C S0100230 


0***********************************************************************3Q]^qq240 


C 


S0100250 


c********* 


PREPARING PROGRAM FOR EXECUTION ************20100260 


C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

C 

c 

c 


:TR,/RMAS,1G,2G,3G,4G 

The above command compiles the source code of REEDM where "IG" 
through "4G" respectively correspond to the FORTRAN compiler 
(FTN4 or FTN4X) options two through five. 


:TR,/RMLD,1G 

The above command loads the REEDM program for execution. Option 
"IG" is a logical unit number to which the load map listing is 
sent. 


:TR,/RMRP,SP,2G,3G 

Optionally, the above command may be used to save the REEDM 
program as a type 6 file on disc. The desired disc cartridge 
number is specified on option "2G". Transfer file ^sRMRP has 
other options which are described in the transfer file comments. 


S0100270 
SO 100180 
SO 100290 
S0100300 
S0100310 
S0100320 
S0100330 
S0100340 
S0100350 
S0100360 
S0100370 
S0100380 
S0100390 
S0100400 
S0100410 
S0100420 
S0100430 
S0100440 
S0100450 
S0100460 
S0100470 
S0100480 
S0100490 . 


2 



fc**** PROGRAM EXECUTION ********** 

:RU,REEDM, 1G,2G,3G,4G,5G 

The above coniinar.d schedules REEDM where the user may pass upto 
five logical unit numbers having the following definitions: 

IG - Input data logical unit number. This number is usually 
(as is the defaulO the terminal from which the user 
has scheduled the program. The user may enter a non- 
terminal number for ”1G". In this case the program 
assumes a batch mode-type run which is discussed below. 
Moreover, if "IG" is set to 98 or 99, plot forms are 
generated. Refer to a section below for a discussion 
of this option. 

2G - Print output logical unit number. This number is 
usually the printer (logical unit 6). 

3G - Meteorological profile plot logical unit number. This 
number defaults to 12« 

AG - Maximum centerline profile plot logical unit number. 

5G - Isopleth plot logical unit number. 


S0100500 
S0100510 
************50 100520 
S0100530 
S01005A0 
S0100550 
pass upto S0100560 
tions: S0100570 

S0100580 
is usually S0100590 

he user S0100600 

r a non— S0100610 

rogram S0100620 

sed below. S0100630 

rras are SO 100640 

scussion S0100650 

S0100660 
r is S0100670 

S0100680 
er. This S0100690 

S0100700 
number. S0100710 

S0100720 
S0100730 


BATCH MODE PROGRAM EXECUTION 
;RU, REEDM, IG, 2G, 3G,4G, 5G 


S0100740 

************50100750 

S0100760 


As mentioned above if the first logical unit number passed in 
the program execution command ("IG") is not a terminal unit then 
the program executes in a batch mode. All input data required 
to execute the program are read from the entered logical unit 

number. ^ ^ . 

In this mode, preparation of an input data file is necessary 

before scheduling the program. For example, if the input data 
file exists on magnetic tape that has been positioned to the 
correct file and is on tape drive unit 8 then "IG" may be set 
to 8 in the program execution command. Or if, for example, 
the input data exists on a disc file, the disc file must first 
be associated with a valid logical unit number by using the 
File Manager "SL" command (:SL,50,"f ile name"). Then set IG 
to the associated logical unit number (50) in the program 
execution command. 

The batch mode has no user interaction except in special cases. 
As noted in the discussion of input data records 18 through 22 
described in the next section, the user may indicate in the 
input data file that user interaction is desired. In these 
special cases the program ‘prompts the user for input in the same 
manner as the interactive mode. When the program or user is 
done with that portion of input, the program returns to the 
input data file for input and resumes the batch mode. 


3 



The following section is a description of the content, foTmiat 
and order of data expected in the input data file for batch mode 
execution. 


C********* 

C 


PLOT FORM GENERATOR PROGRAM EXECUTION 


;RU,REEDM,98or99, ,3G,4G 


I'Jhen 98 or 99 is passed in the first parameter ("IG") of the 
program execution command, REEDM enters a plot form generator 
mode. No model calculations or other processing is performed 
in this mode. Upon exit of this mode the program terminates. 
If the user enters 98 for "IG", the program will plot the 
meteorological profile form on the plot unit specified in 
parameter "3G" (default is 12). The program prompts the user 
to ready the plot device before plotting. Upon completion of 
plotting a form, the program again prompts the user to plot 
another form or stop. 

If the user enters 99 for "IG", the program will plot the 
maximum centerline form on the plot unit specfied in parameter 
"4G". Again, the program prompts the user to ready the plot 
device, re-plot the form or stop. 


C********* BATCH MODE INPUT PARAMETERS *********^ 

C 

C 

C*RECORD 01 (A2) 

C 

C RUN TYPE - Enter "0" for operational and "P" for production run 
C types. A blank record defaults to operational. 

C Note that the batch mode does not allow a research 

C run type. 

C 

C*REC0RD 02 (3A2) 

C 

C FILE NAME - Enter the meteorological data sounding file name. 

C A blank record defaults to file name "RRSOND". 

C If TAPE#// is entered, the program assumes it is 

C to read the sounding data from magnetic tape unit 

C lu 8 in the KSC65 format starting at the sounding 

C number given by ////. 


, foTmiat S0101020 

batch mode S0101030 
S0101040 
S0101050 
S0101060 
************ 20 101070 
S0101080 
S0101090 
SOlOllOO 
of the SOlOlllO 

;nerator S0101120 

informed S0101130 

linates. S0101140 

the S0101150 

1 in S0101160 

he user S0101170 

tion of S0101180 

i plot SO 10 1190 

S0101200 
the S0101210 

arameter S0101220 

e plot S0101230 

S0101240 
S0101250 
S0101260 
*******:«r;S:***gQ ]^Q 270 
S0101280 


C*REC0RD 03 
C 


NUMBER OF RUNS - 


S0101450 

This record is entered only for production ("P") runs. S0101460 

S0101470 

JNS - Enter a value for the number of data cases to S0101480 
be processed under the production run type. S0101490 

Default is 1. The program assumes you have S0101500 

stacked this number of sounding data sets on S0101510 
file or magnetic tape and produces calculations S0101520 
for the specified number of data sets. S0101530 
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C*RECORD 04 (A2) 

C 


C 
C 
C 
C 
C 

C*RECORD 05 
C 


"C" for the concentration/dosage. 


"W" for the 
for the gravitational 


MODEL - Enter 

washout deposition and "G 
deposition models. A blank record defaults to the 
concentration/dosage model. 


(I4,1X,R1.A2,1X.I2,1X,A2,A1,1X,I4) 


C 
C 

c 

c 

c 

c 

c 

c 

c 

C*REC0RD 06 
C 


LAUNCH DATE - 


Enter the launch time and date. A blank record 
defaults to the date given on record 5 of data 
file ?LTIME. If data file 7LTIME does not exist, 
the default is the current time and date. Enter 
3 f our~digit hour , three~character time zone , 
two-digit day of the month, three-character month 
and four-digit year, where each item is separated 
by one blank space. 


(A2) 


LAUNCH VEHICLE - Enter "S" for Space Shuttle, "T" for Titan, 
"D2" for Delta 2914, and "D3" for Delta 3914 
vehicles. A blank record defaults to the 
Space Shuttle vehicle. 


C 
C 
C 
C 

c 

C*REC0RD 07 
C 
C 
C 

c 

i 

C 

C*REC0RD 08 (*) 

C . 

PROPELLANT TEMP. - Enter the vehicle propellant temperature in 

degrees Celsius. A zero value or blank 
record defaults to the average monthly 
temperature determined by the month entered 
for the launch time in Record 5. 


(A2) 

LAUNCH TYPE - Enter "N" for normal, "S" for single engine, 
and "C" for conflagration launch types. A 
blank record defaults to a normal launch type. 


C 
C 

c 

c 

c 

c 

C*REC0RD 09 
C 


(12A2) This record is entered only for the concentration/ 
dosage ("C") or washout deposition ("W") models. 


C 

C 

C 

C 

C 

C 


SPECIES - Enter "H" for HCl, "A" for A1203, "C2" for C02, and 

"C" for CO species. Note that the C02 and CO species 
applicable only to the concentration/dosage model. 

A blank record defaults to the HCl species. 


(A2) 


C*REC0RD 10 

Q 

C COMPLEX NUMBER - Enter the launch complex number. A blank record 

C defaults to a number depending on the launch 


S0101540 

S0101550 

S0101560 

S0101570 

S0101580 

S0101590 

S0101600 

S0101610 

S0101620 

S0101630 

S0101640 

S0101650 

S0101660 

S0101670 

S0101680 

S0101690 

S0101700 

S0101710 

S0101720 

S0101730 

S0101740 

S0101750 

S0101760 

S0101770 

S0101780 

S0101790 

S0101800 

S0101810 

S0101820 

S0101830 

S0101840 

S0101850 

S0101860 

S0101870 

S0101880 

S0101890 

S0101900 

S0101910 

S0101920 

S0101930 

S0101940 

S0101950 

S0101960 

S0101970 

S0101980 

S0101990 

S0102000 

S0102010 

S0102020 

S0102030 

S0102040 

S0102050 
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vehicle specified ,in record 6. 


C*RECORD 11 (A2) OR (*) ' 

C 

C 

C CALCULATION HEIGHT - 


C*RECORD 12 
C 


C CLOUE 
C 
C 
C 

C** Note: 
C** 

C 

C*RECORD 13 
C 


CLOUD SHAPE 


.This record is entered only for the 
concentration/dosage model. 

- Enter "S" for surface and "ST" for cloud 
stabilization calculation heights. 
Additionally, the user may enter a value 
for the calculation height in meters. 

A zero value or blank record defaults to 
a surface calculation height. 


Enter "E" for elliptical and "S" for spherical 
cloud shapes. A blank record defaults to an 
elliptical cloud shape. 


Records 13 through 16 are entered only when the washout 
deposition ("W") model is selected in record 4. 


MAXIMUH OR TIME-DEPENDENT - 


Enter "M" for maximum possible and 
"T" for time dependent washout 
deposition calculations. A blank 
recofd defaults to the maximum 
possible washout deposition. 


C*RECORD 14 (A2) OR (*) 

C 

C RAINFALL RATE - En 


C RAINFALL RATE - Enter "H" for heavy (0.3), "M" for moderate (0.2) 
C and "L" for light (0.1) rainfall rates in inches 

C per hour. Additionally, the user may enter a 

C value for the desired rainfall rate. A zero 

C value or blank record defaults to a heavy 

C rainfall rate. 

C 

C*REC0RD 15 (*) This record is entered only for time-dependent 

C washout deposition. 

C 

C TIME - Enter the time in seconds the rain starts after the 
C launch. A blank record defaults to zero seconds. 


RAIN DURATION - 


Enter the duration of the rain In hours after 
the launch. A blank record defaults to one 
hour. 


For a production run type, specified in record 1, sets of 
records 17 through 20 must be entered. The number of sets 


S0102060 

S0102070 

S0102080 

S0102090 

S0102100 

S0102110 

S0102120 

S0102130 

S0102140 

S0102150 

S0102160 

S0102170 

S0102180 

S0102190 

S0102200 

S0102210 

S0102220 

S0102230 

S0102240 

SO 102250 

S0102260 

S0102270 

S01022S0 

S0102290 

S0102300 

S0102310 

SO 102320 

S0102330 

S0102340 

S0102350 

S0102360 

S0102370 

S0102380 

S0102390 

S0102400 

S0102410 

S0102420 

S0102430 

S0102440 

S0102450 

S0102460 

S0102470 

S0102480 

S0102490 

S0102500 

S0102510 

S0102520 

S0102530 

S0102540 

S0102550 

S0102560 

S0102570 
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c** 

c 

C*RECORD 17 
C 


equals the number of runs specified in record 3. 
(A2) 


PLOT MET. PROFILE - Enter "Y" or "YE" for yes and "N" or "NO" 

for no regarding whether or not the meteor- 
ological profile is to be plotted. 

Enter "F" to indicate yes and to plot the 
profile form. This is the portion of the 
plot that is independent of the sounding 
data. A blank record defaults to yes with 
no form plotted. 


C 
C 

c 

c 

c 

c 

c 

c 

c 

C*RECORD 18 
C 
C 
C 
C 
C 

c 

c 

c 

c 

C*RECORD 19 

c 


(A2) 


BOUNDARY LAYERING - Because the default boundary layers values 

are not known apriori, enter "Y" or "YE" to 
display the default boundary layers values 
and interactively modify the values. Any 
other entry for this record causes the 
program to use the default boundary layers 
values. 


(A2) 
SIGMA(A) - 


C 
C 

c 

c 

c 

c 

C*RECORD 20 
C 
C 
C 
C 
C 
C 
C 

C** Note; 
C** 

C 

C*REC0RD 21 
C 


Because the default SIGMA(A) value is not known 
apriori, enter "A" to display the default SIGMA(A) 
value and interactively modify the value. Any 
other entry for this record causes the program to 
use the default SIGMA(A) value. 


(A2) 


SIGMA(E) - Because the default SIGMA(E) value is not known 

apriori, enter "A" to display the default SIGMA(E) 
value and interactively modify the value. Any 
other entry for this record causes the program to 
use the current value of SIGMA(A) for SlGMA(E) . 


For a production run type, specified in record 1, 
records 21, 22, 25 and 26 are not entered. 


(A2) 


C 

C 

C 

C 

C 

C 

C 

C 


PLOT MAX. CENTERLINE - 


"NO" 


Enter Y or YE for yes and N or 
for no regarding whether or not the 
maximum centerline result values are to 
be plotted. Enter "F" to indicate- yes 
and to plot the maximum centerline form. 
This is the portion of the plot that is 
independent of the calculated results. 

A blank record defaults to yes with no 


S0102580 

S0102590 

S0102600 

S0102610 

S0102620 

S0102630 

S0102640 

S0102650 

S0102660 

S0102670 

S0102680 

S0102690 

S0102700 

S0102710 

S0102720 

S0102730 

S0102740 

S0102750 

S0102760 

S0102770 

S0102780 

S0102790 

S0102800 

S0102810 

S0102820 

S0102830 

S0102840 

S0102850 

S0102860 

S0102870 

S0102880 

S0102890 

S0102900 

S0102910 

S0102920 

S0102930 

S0102940 

S0102950 

S0102960 

S0102970 

S0102980 

S0102990 

S0103000 

S0103010 

S0103020 

S0103030 

S0103040 

S0103050 

S0103060 

S0103070 

S0103080 

S0103090 
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c 

c 

c 

c 

C*RECORD 22 
C 


C 
C 
C 
C 
C 
C 
C 

C* RECORD 23 
C 

c 
c 
c 
c 
c 
c 
c 
c 
c 

C*RECORD 24 
C 
C 
C 
C 
C 
C 
C 
C 
C 

c 
c 
c 
c 
c 
c 
c 
c 

C*RECORD 25 
C 
C 
C 
C 
C 

c 
c 
c 
c 


(A2) 

PLOT ISOPLETHS 


form plotted. 

Note: All plot options are interactive 

with the user. 


Enter "Y" or "YE" for yes and "N" or "NO" for 
no regarding whether or not the isopleths of 
the results are to be plotted, A blank record 
defaults to yes. 

Note: All plot options are interactive with 

the user. 


(A2) 

DISCRETE RECEPTORS 


(*) 


Enter Y or "YE" or a logical unit number 
for yes and "N" or "NO" for no regarding 
regarding whether or not to make calcula- 
tions at user— entered discrete receptor 
locations. If a logical unit number is 
entered, the discrete receptor locations 
are read from that number. A blank record 
defaults to yes. 


This record is entered only if a yes response is 
given in record 23. 

Note: This record is repeated until’ a negative 
value is entered for the First parameter XRANGE) 
or upto a maximum of 60 times, whichever occurs 
first. 


RANGE - Enter the distance from the launch pad to the discrete 
receptor location in meters. 

BEARING - Enter the bearing in degrees the discrete receptor 
is located with respect to North. 

HEIGHT — Enter the height of the discrete receptor in meters 

(calculation height). Note: This parameter is entered 

only for the concentration/dosage model. 

COMMENTS - Enter any comment information desired in input columns 
31 through 50, This information is printed on the 
output listing. Default is all blank. 


(A2) This record is entered only for the concentration/ 
dosage model. 

CALCULATION HEIGHT - Enter "Y" or "YE" for yes and "N" or "NO" 

for no regarding whether or not to change 
the calculation height. For a yes response 
follow this record with a calculation 
height value and re-enter records 17 
through 24. A blank record defaults to yes. 


S0103100 

S0103110 

S0103120 

S0103130 

S0103140 

S0103150 

S0103160 

S0103170 

S0103180 

S0103190 

S0103200 

S0103210 

S0103220 

S0103230 

S0103240 

S0103250 

S0103260 

S0103270 

S0103280 

S0103290 

S0103300 

S0103310 

S0103320 

S0103330 

S0103340 

S0103350 

S0103360 

S0103370 

S0103380 

S0103390 

S0103400 

S0103410 

S0103420 

S0103430 

S0103440 

S0103450 

S0103460 

S0103470 

S0103480 

S0103490 

S0103500 

S0103510 

S0103520 

S0103530 

S0103540 

S0103550 

S0103560 

S0103570 

S0103580 

S0103590 

SO 103600 

S0103610 
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WASHOUT DEP. CALCULATION - 


C*RECORD 
C 
C 
C 
C 
C 
C 
C 
C 
C 

c 

c 

c 

C*RECORD 27 
C 

c 
c 
c 
c 
c 
c 
c 
c 
c 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 


(A2) This record is entered only for the washout 
depositon model. 


Enter "Y" or "YE" for yes and "N" or 
"NO" for no regarding whether or not 
to change the washout deposition 
calculations to maximum possible or 
time-dependent. For a yes response 
re-enter records 13, 15 (if 
applicable) and 17 through 24 
following this record. A blank 
record defaults to yes. 


(A2) 


ANOTHER CASE - Enter "Y" or "YE" for yes and ”N" or "NO" for no 
■ regarding whether or not to process another 
meteorological data case. For a yes response 
follow this record with another set of data 
input parameters beginning at record 1. 
Otherwise, the REEDM program terminates - 
A blank record defaults to yes. 


UPDATE 8213 INFORMATION 


S0102620 
S0103630 
S0103540 
S0103650 
S0103660 
S0103670 
S0103680 
S0103690 
S0103700 
S0103710 
S0103720 
S0103730 
S0103740 
S0103750 
S0103760 
S0103770 
S0103780 
S0103790 
S0103S00 
S0103810 
S0103820 
S0103830 
S0103840 
S0103S50 
********* A* A SO 103860 
S0103870 
S0103S80 
S0103S90 
S0103900 


This update replaces all previous updates of the REEDM programs 
and is not compatible with any previous updates. The following 
is a summary of the program changes from the previous update 8150. S0103910 

S0103920 

The program now exists as a segmented program - one main program 
with twelve segments. The previous versions consisted of 
several independent programs. This change eleminates the need 
for a disc file containing the common information being passed 
apong the programs. 


Gravitational deposition results are calculated in particles per 
square meter in addition to the milligrams per square meter units, 
Moreover, for research type runs the particles calculated are 
printed for each settling category. 


The default launch 
?LTIME rather than 
and 7R50TY are not 


time and date are now on record 1 of file 
record 5 of 7R50CR or ?R50TY. Files ?R50CR 
longer used (see record 05 above). 


The maximum number of discrete receptors is 60 instead of 20. 

The discrete receptor locations may be read by the program from 
a logical unit number specified by the user. In addition to 
entering "yes" or "no" in reponse to the calculation of discrete 
receptors prompt, the user may also enter a logical unit number. 


S0103930 

S0103940 

S0103950 

S0103960 

S0103970 

S0103980 

S0103990 

S0104000 

S0104010 

S0104020 

S0104030 

S0104040 

S0104050 

S0104060 

S0104070 

S0104080 

S0104090 

S0104100 

S0104110 

S0104120 

S0104130 
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C In this case the program will read all discrete receptor loca- S0104140 

C tions from the logical unit number entered. The program will S0104150 

TISO(10),TITLE(14),SIGPP(29),SIGLL(29),VS(20), S0104480 

FS(20) ,MDLNAM(12) ,DBAR(20) S0104490 

C COUNTERS , FLAGS , GENERAL AND INDEX VARIABLES S0104500 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S0104510 

MODEL4,MODEL5,MODEL6 S0104520 

INTEGER RUNNUM,RT,CL,CS S0104530 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS ,NBK,QC,QT,HEAT,ZM,H, S0104540 

DPDZ,TAmC,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S0104550 

SIGZ, ISNDFO, CRT, LAYTOPO) ,ITDU, KEEP S0104560 

,MIXING,MAXDEP,LAYB0T(3) S0104570 

, ALTSV, BATCH, CL ( 14) ,CS( 10) , GASSET, lAGAIN, S0104580 

ICHAR(12),IDXCL,IDXCS,IERR0R(5),IFP1IT(80), S01C4590 

MINUS1,MINUS9,MINS1,MINS9, S0104600 

M0DEL4 , MODELS , M0DEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , SO 1 046 1 0 
RT(24) ,TPROPC,IDXRT S0104620 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. SO 1046 30 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S0104640 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S0104650 

CLRLNE,INSLNE, DELINE S0104660 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,IN\T1F(2) , S0104670 

INVNDR(2),ULINE(2), S0104680 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP ,50104690 
CLRLNE,INSLNE, DELINE, S0104700 

lESCAJO) ,NULL,IBLNK, S0104710 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S0104720 

C VEHICLE PARAMETERS SO 104730 

COMMON /VCLPR/ VPAR(17) S0104740 

C TIME PARAMETERS S0104750 

COMMON /TIME/ JTIME, JDAY,JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S0104760 

LDAY,LYEAR,ISMON(2) ,JMON(2) ,LMON(2) ,LSDT(2) S0104770 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) SO 104780 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S0104790 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S0104800 

C LAYER PARAMETERS SO 1048 10 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S0104820 

SIGYO(29) S0104830 

C CALCULATED FOUNDRY DATA (FOR NEW LAYERS) S0104840 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S0104850 

C CALCULATED NEW LAYER PARAMETERS S0104860 

COMMON /NLYER/DDIR(32) ,DIRN (32) , DSPEED (32) , SIGAPN(32) , SIGEPN (32) , S0104870 
SPEEDN(32) S0104880 

C CONVERSION FACTORS S0104890 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S0104900 

C S0104910 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************SO 104920 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S0104930 

C READ/WRITE BUFFER SO 104940 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S0104950 
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c 

C EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(1)) , (lOU, IPAR(2) ) , (IPUl , IPAR(3) ) 

. , (IPU2,IPAR(A)) , (IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP .GRVSET) , (IFRMT(l) .lERMTl) 

C 

C**** END OF COMMON AREA 

Cc 

c 

INTEGER DFLUS(5) ,CRTAPA(10) 

C 

c 

c THE FOLLOWING DATA STATEMENTS ARE SITE-SPECIFIC. 

C 

C**** KSC ENHANCED DISPLAY CRT LUS. 

DATA CRTARA /7, 16, 8*0/ 

C**** MSFC ENHANCED DISPLAY CRT LUS. 

C++++ DATA CRTARA /A, 5, 7, 7*0/ 

C**** H.E. CRAMER CO. ENHANCED DISPLAY CRT LUS. 

C++++ DATA CRTARA /10,11,8*0/ 

Q 

C DEFAULT LOGICAL UNIT NUMBERS. DFLUS(l) THROUGH DFLUS(5) 

C RESPECTIVELY CORRESPOND TO THE FIVE NUMBERS PASSED IN 

C THE RUN STATEMENT (RU,REEDM, IPl , IP2 , IP3 , IPA,IP5) . THE 
C PURPOSE OF EACH LOGICAL UNIT NUMBER IS DISCUSSED ABOVE. 
C**** KSC DEFAULT LUS. 

DATA DFLUS /7 , 6 , 12 , 20 , 2 1/ 

C**** MSFC default LUS. 

C++++ DATA DFLUS / 1 , 6 , 12 , 12 , 12/ 

C**** H.E. CRAMER CO. DEFAULT LUS. 

C++++ DATA DFLUS /lO, 6, 12, 12, 12/ 

C 

c 

DATA IFJ/IHF/ 

C 

C 

c**** FIRST EXECUTABLE STATEMENT. 

C 

CALL RMPAR(IFRMT) 

IF(NNNEST) 10,110,100 
10 CONTINUE 
NNNEST = 1 
C 

c**** determine execution name given to reedm 

c 

CALL PNAME(NAMEP) 

c 

c**** initialize logical units. 

c 

do 20 I = 1,5 
IPAR(I) = DFLUS (I) 

IF(IFRMT(I) .GT. 0) IPAR(I) = IFRMT(I) 


S0104970 

S0104980 

S01C4990 

S0105000 

S0105010 

S0105020 

****S0105030 

S0105040 

S0105050 

S0105060 

S0105070 

S0105080 

S0105090 

S0105100 

S0105110 

S0105120 

S0105130 

S0105140 

S0105150 

S0105160 

S0105170 

S0105180 

S0105190 

S0105200 

S0105210 

S0105220 

S0105230 

S0105240 

S0105250 

S0105260 

S0105270 

S0105280 

S0105290 

S0105300 

S0105310 

S0105320 

S0105330 

S0105340 

S0105350 

S0105360 

S0105370 

S0105380 

S0105390 

S0105400 

S0105410 

S0105420 

S0105430 

S0105440 

S0105450 

S0105460 

S0105470 

S0105480 
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20 CONTINUE 

IF (IFRMT(2) .LT. 0) IPAR(2) = IABS(IFRMT(2) ) 
C 

ICU = 0 

NCU = LOGLU(ICU) 

CRT = .FALSE. 

DO 30 I = 1,10 

30 IF(ICU .EQ. CRTARA(I)) CRT = .TRUE. 

IF (IFRMT(2) .LT. 0) CRT = .FALSE. 

IF (ICU .LT. 0. OR. ICU .GT. 15) ICU = NCU 
IF(CRT) GOTO 50 
DO 40 I = 1,28 
40 ALTSET(I) = NULL 
TAB = 40B 
TAB2 = NULL 

C* CHECK FOR PLOT FORM GENERATION. 

50 IF(IIU .NE. 98) GOTO 60 

11 = IPUl 

12 = 4 
GOTO 70 

60 IF(IIU .NE. 99) GOTO 80 

11 = IPU2 

12 = 10 

70 NNNEST = 5 

CALL L0ADS(I2, 0,0, 11,0, BATCH) 

80 CONTINUE 

C* CHECK FOR BATCH MODE DATA INPUT. 

BATCH = IFTTY(IIU) .EQ. 0 
C 
C 

90 NNNTRY = 1 
lERROR(l) = 0 
GOTO 130 
C 

c**** CHECK FOR UNRECOVERABLE ERROR (NEGATIVE), 
C**** NORMAL RETURN (ZERO) OR 
C**** RESTART CONDITION (POSITIVE). 

C 

100 CONTINUE 

IF(IERROR(D) 110,120,90 
no NNNTRY = 7 
GOTO 140 
C 

C**** DETERMINE PROGRAM CALL LEVEL DEPTH (NNNEST). 

C 

120 CONTINUE 

GOTO (130,150,220,280,330,140), NNNEST 
C 

C*** LOAD SEGMENT READM (NNNEST = 1). 

C 

130 CALL LOADSd, 0,0, 0,0, BATCH) 

140 CALL L0ADS(13, 0,0, 0,0, BATCH) 


S0105490 

S0105500 

S0105510 

S0105520 

S0105530 

S0105540 

S0105550 

S0105560 

S0105570 

S0105580 

S0105590 

S0105600 

S0105610 

S0105620 

S0105630 

S0105640 

S0105650 

S0105660 

S0105670 

S0105680 

S0105690 

S0105700 

S0105710 

S0105720 

S0105730 

S0105740 

S0105750 

S0105760 

S0105770 

S0105780 

S0105790 

S0105800 

S0105810 

S0105820 

S0105830 

S0105840 

S0105850 

S0105860 

S0105870 

S0105880 

S0105890 

S0105900 

S0105910 

S0105920 

S0105930 

S0105940 

S0105950 

S0105960 

S0105970 

S0105980 

S0105990 

S0106000 


12 



LOAD ONE OF THE SEGMENTS SCHEDULED BY READM (NNNEST = 2). 
CONTIIHJE 

IF(NNNTRY .LT. 5) GOTO 210 
IF(NNNTRY .NE. 5) GOTO 170 
DETERMINE IF EXHAUST CLOUD CAN BE PLOTTED. 

IF (GOOD .NE. 1) GOTO 160 

NNNEST = 2 

LLNTRY =6 

GOTO 210 

NNNTRY = 6 

IF(NNNTRY .NE. 6) GOTO 200 

IF(BATCH) GOTO 190 

CONTINUE WITH MODEL CALCULATIONS? 

WRITE ( ICU , 9 004 ) INVNDR , INV , OFF , ULINE , OFF 
INPTl = IBLNK 
READ (IIU, 9001) INPTl 
WRITE(ICU,9002) lESCAJ 

IF (INPTl .EQ. INJ. OR. INPTl .EQ. INOJ) GO TO 90 

IF aWPTl.EQ. MINUS 1 .OR. INPTl . EQ.MINUS9) GOTO 90 

IF UNPTl. EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 180 

WRITE (ICU, 9003) INV, OFF, 20, 4 

GO TO 170 

WRITE(ICU,9008) INV, OFF 
GOTO MODEL SEGMENT. 

NNNTRY = MODEL + 2 
LLNTRY = 0 
GOTO 210 

RETURN TO MODEL SEGMENT AFTER PLOTTING. 

NNNTRY = MODEL + 5 
LLNTRY = 0 

CALL LOADS (NNNTRY , LLNTRY ,1,0,0, BATCH) 

LOAD A SEGMENT SCHEDULED BY A SEGMENT IN LEVEL 2 (NNNEST =3). 


) CONTINUE 

IF(NNNTRY .LT. 4) GOTO 270 
IF (IRUN .EQ. 1) GO TO 200 
12 = IFJ 

PLOT MAXIMUM CENTERLINE? 

IF(NNNTRY .NE. 4) GOTO 250 

) IF(. NOT. BATCH)17RITE(ICU, 9005) CURSUP, DELINE, INVNDR, INV, OFF, ULINE, 
*OFF 

INPTl = IBLNK 
READ(IIU,9001) INPTl 

IFdNPTl .EQ. MINUS9 .OR. INPTl .EQ. MINUSl) GOTO 90 
WRITE(ICU,9002) lESCAJ 

IF(INPT1 .EQ. INJ .OR. INPTl .EQ. INOJ) GOTO 250 
IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 240 
WRITE (ICU, 9003) INV, OFF, 21,0 
GO TO 230 
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240 NNNTRY = 4 
LLNTRY = 7 
GOTO 270 

C* PLOT ISOPLETKS? 

250 IF (.NOT. BATCH) WRITE(ICU, 9006) INVNDR, INV,OFF,ULINE,OFF 
INPTl = IBLNK 
READ (IIU, 9001) INPTl 
IF(. NOT. BATCH) WRITE(ICU, 9002) lESCAJ 
IFUNPTl .EQ. INJ .OR. INPTl .EO. INOJ) GOTO 200 
IF (BATCH) GOTO 260 
IFdNPTl .EQ. MINUSl) GOTO 230 
IFdNPTl .EQ. MINUS9) GOTO 90 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 260 
WRITE (ICU,9003) INV,0FF,22,0 
GO TO 250 

260 LLNTRY = MODEL + 5 
NNNEST = 2 
NNNTRY = 6 
270 CONTINUE 

CALL LOADS (NNNTRY, LLNTRY, 2 , IPU2 , 12 , BATCH) 

C 

C*** LAST LEVEL (NNNEST = 4). CALL MET. PROFILE PLOT FORM 
C*** GENERATOR OR PLOT SOUNDING DATA. 

C 

280 CONTINUE 

NNNEST = LLNEST 
12 = IFJ 

IF (NNNTRY INE. 1) GOTO 320 
IF (BATCH) GOTO 310 

WRITE (ICU , 900 7 ) CLRDSP , IPAR ( 3 ) , INV , OFF , ULINE , OFF 
290 INPTl = IBLNK 

READ (IIU, 9001) INPTl 
WRITE(ICU,9002) IESCAJ,IESCAJ 

IFdNPTl .EQ. MINUSl .OR. INPTl .EQ. MINUS9) GOTO 90 
WRITE(ICU,9002) lESCAJ 
NNNTRY = 2 

IF (INPTl .EQ. IBLNK) GO TO 320 
IF dNPTl .EQ. IFJ) GO TO 300 
WRITE (ICU, 9003) INV, OFF, 17,1 

WRITE (ICU, 9007) IBLNK, IPAR (3 ), INV, OFF, ULINE, OFF 
GO TO 290 
300 CONTINUE 
NNNTRY = 1 
310 NNNEST = 4 
320 CONTINUE 
LLNTRY = 2 
NNNTRY = NNNTRY + 3 

CALL LOADS (NNNTRY , LLNTRY , 0 , IPU 1 , 12 , BATCH) 

C 

C*** PROGRAM TERMINATION FROM PLOT FORM GENERATION. 

C 

330 CONTINUE 


S0106530 

S0106540 

S0106550 

S0106560 

S0106570 

S0106580 

S0106590 

S0106600 

S0106610 

S0106620 

S0106630 

S0106640 

S0106650 

S0106660 

S0106670 

S0106680 

S0106690 

S0106700 

S0106710 

S0106720 

S0106730 

S0106740 

S0106750 

S0106760 

S0106770 

S0106780 

S0106790 

S0106800 

S0106810 

S0106820 

S0106830 

S0106840 

S0106850 

S0106860 

S0106870 

S0106880 

S0106890 

S0106900 

S0106910 

S0106920 

S0106930 

S0106940 

S0106950 

S0106960 

S0106970 

S0106980 

S0106990 

S0107000 

S0107010 

S0107020 

S0107030 

S0107040 
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o o 


STOP S0107050 

S0107060 
S0107070 

CF*** FORMAT STATEMENTS. SO 107080 

QF S0107090 

9001 FORMAT(A0A2) S0107100 

9002 FORMAT (2A2.A1) S0107110 

9003 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2,6H REC. SO 107 120 

*,I2,1H. ,11/) S0107130 

9004 FORMAT(55H DO YOU WISH TO CONTINUE WITH THE MODEL CALCULATIONS? (.S0107140 

1 2A2,1HY,2A2,2HES,2A2,1H,,2A2,1HN,2A2,4H0):_) S0107150 

9005 FORMAT (2A2, 4 3H DO YOU WISH TO PLOT MAXIMUM CENTERLINES? (,2A2, S0107160 

1 1HY,2A2,2HES,2A2,1H,,2A2,1HN,2A2,4H0):_) S0107170 

9006 FORMAT(33H DO YOU WISH TO PLOT ISOPLETHS? ( , 2A2 , IHY, 2A2 , 2HES , S0107180 

1 2A2,1H,,2A2,1HN,2A2,4H0):_) S0107190 

9007 F0PJ1AT(A2,51H MOUNT A METEOROLOGICAL PROFILE FORM ON PLOTTER LU , S0107200 

1I2/32X,2A2,14HSPACE - RETURN , 2A2 , 1 IH WHEN READY/ S0107210 

2 32X,6HENTER ,2A2, 1HF,2A2, 19H TO PLOT THE FORM:_) S0107220 

9008 F0RMAT(1X,2A2,11HPLEASE WAIT.2A2/) S0107230 

end S0107240 


15 


SUBROUTINE LOADS (NTRY , LTRY , INDEX, IPRAMl , IPRAM2 , BATCH) 

, , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 

THIS ROUTINE SCHEDULES THE SEGMENT INDICATED BY THE FORMAL 
ARGL’MENT NTRY. NTRY AND INDEX ARE USED TO ACCESS THE ARRAY 
NAMER WHICH CONTAINS THE SEGMENT NAMES. 

IF A SEGMENT WAS NOT SUCCESSFULLY LOADED (lERR = 5), A "WAIT 
UNTIL LOADED LOOP" IS PERFORMED. 

ONCE THE SEGMENT NAME HAS BEEN DETERMINED, THE OLD ENTRY 
POINT IS REPLACED BY THE NEW ONE. 


INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

ISHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , I S IG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR, SIGNER, LSITE, BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE (3 ) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR, 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

CLRLNE , INSLNE , DELINK 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,IN\T1F(2) , 
INVNDR(2) ,ULINE(2), 

. ' TAB, TAB2, SETTAB, CLRTAB, CURSUP, CURSDN, CURLFT, CLRDSP, 

CLRLNE , INSLNE , DELINK , 

IESCAJ(3) ,NULL,IBLNK, 

IPAR ( 5 ) , ICU , lYS J , lYES J , IN J , INO J , NAMEP ( 3 ) 

LOGICAL BATCH 

DIMENS I ON NAMER ( 3 , 1 3 ) , NENTRY ( 1 1 , 2 ) , IMES S ( 6 ) 


EQUIVALENCE ( I lU , IPAR ( 1 ) ) , (lOU , IPAR( 2) ) 

DATA NAMER /2HRE, 2HAD, IHM, 2HRD, 2HAT, IHM, 2HRC, 2HLD, IHM, 

1 2HRM, 2HMR, IHM, 2HRM, 2HMR, IHM, 2HRC, 2HON, IHM, 

2 2HRP , 2HDP, IHM, 2HRG, 2HDP’, IHM, 2HRD , 2HHM, IHM, 

3 2HRC,2HIM,1HM,2HRC,2HN0,1HM,2HRG,2HPD.1HM, 

4 2HRE.2HDA, IHM/ 

DATA NENTRY /2 , 3 , 3 ,4 , 5 , 6 , 7 ,8 , 6 , 7 , 8 , 

1 9,9,9,10,10,10,10,4*0/ 

DATA IMFSS/2HOF,2H ,,3*2H ,2H,8/ 
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IF (NTRY .LT. 0) GO TO 80 
1 = 0 
J = 0 
IPRAM3 = 1 
NSEG = NTRY 

IF (INDEX .GT. 0) NSEG = NENTRY (NTRY, INDEX) 

IF(LTRY ,EQ. 0) GOTO 10 

IF(NSEG.EQ. 10.AND.NTRY.EQ.6.AND.INDEX.EQ.2) IPRAM3 = 2 
NTRY = LTRY 
LTRY = 0 

10 IF (NTRY .EO. 9. AND. NSEG .EQ. 6) NSEG = 11 
IF (NTRY .EO. 11. AND. NSEG .EQ. 8) NSEG = 12 
IF (NSEG .EQ. 5) IPRAM3 = 2 
LSTSEG = NSEG 
LPRAMl = IPRAMl 
LPRAM2 = IPPvAM2 


LPRAM3 = IPRAH3 
20 CONTINUE 

CALL SEGLD (NAMER(1, NSEG) ,IERR, IPRAMl, IPRAM2.IPRAM3) 

I = I+l 

IF (I .'GT. 2) GO TO 30 
IF (lERR .NE, 5) GO TO 30 
IF (NTRY .LT. 0) GO TO 20 
GO TO 10 

30 IF (BATCH) GO TO 50 
J = J+1 

IF (J .GT. 3) GO TO 50 

WRITE (ICU,9001) INV,(NAMER(L,NSEG),L=1,3),0FF 
40 WRITE (ICU,9002) INV, (NAMER(L,NSEG) ,L=1 ,3) ,OFF,INV,NAMEP,OFF,INV 
*NAMEP,OFF 
PAUSE 

IF (NTRY .LT. 0) GO TO 20 
GO TO 10 

50 WRITE (IOU.9003) (NAMER(I ,NSEG) , 1=1 , 3) 

60 CONTINUE 
STOP 

70 RETURN 
80 NSEG = LSTSEG 
IPRAMl = LPRAMl 
IPRAM2 = LPRAM2 
IPRAM3 = LPRAM3 

\miTE (IOU,9004) INV, (NAMER(I, NSEG) ,1=1,3) , OFF, INV, IVERSN, OFF 
IF (BATCH) GO TO 60 

WRITE (ICU,9004) INV, (NAMER( I, NSEG) ,1=1,3) , OFF, INV, IVERSN, OFF 
DO 90 1=1,3 

90 IMESS(I+2) = NAMER(I,NSEG) 

I = MESSS(IMESS,12) 

GO TO 40 

9001 FOPvMAT (2A2,41H*** REEDM ERROR 002, CANNOT LOAD SEGMENT ,5A2/) 

9002 FORMAT (13HEITHER TYPE ' ,2A2,3HRP, ,5A2,22H' UNDER FMGR OR TYPE ' 
*2A2,3HOF,,3A2,2H,l,2A2,21H’ UNDER RTE TO ABORT. /6HTYPE ’ ,2A2, 
*3HGO, ,5A2, 13H' TO CONTINUE) 


S0200510 
S0200520 
S0200530 
S0200540 
S0200550 
S0200560 
S0200570 
S0200580 
S0200590 
S0200600 
S0200610 
S0200620 
S0200630 
S0200640 
S0200650 
S0200660 
S0200670 
S0200680 
S0200690 
S0200700 
S0200710 
S0200720 
S0200730 
S0200740 
S0200750 
S0200760 
S0200770 
S0200780 
, S0200790 
S0200S00 
S0200810 
S0200820 
S0200830 
S0200840 
S0200850 
S0200860 
S0200870 
S0200880 
S0200890 
S0200900 
S0200910 
S0200920 
S0200930 
S0200940 
S0200950 
S0200960 
S0200970 
S0200980 
S0200990 
, S0201000 
S0201010 
S0201020 
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9003 FOR^L^T (////42H *** REEDM ERROR 002, CANNOT LOAD SEGMENT ,3A2) 

9004 FORMAT (2A2.30H *** REEDM ERROR 003, SEGMENT ,3A2,25H HAS WRONG 
*DATE NUMBER, ,2A2/2A2 ,23H MUST BE UPDATE NUMBER ,I4,2A2/) 

END 


S0201030 

UPS0201040 

S0201050 

S0201060 



o o 


BLOCK DATA 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 

cc 

c**** BEGIN COMMON AREA 

04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , I SIG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR, SIGNER , LSITE , BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NTH SO , NTI SO , FILE ( 3 ) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

MOD EL4 , MODELS , M0DEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S I GZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT ( 3 ) 

,ALTSV,BATCH,CL(14) ,CS(10) .GASSET, lAGAIN , 
ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80), 

MINUS 1 , MINUS9 , MINS 1 , MINS9 , 

MOD EL4 , MODELS ,MODEL6 ,NNNEST,NNNTRY,LLNEST,LLNTRY , 
RT(24) ,TPROPC,IDXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

. CLRLNE.INSLNE, DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2) , 


S0300000 
S0300010 
S0300020 
****S0300030 
S0300040 
S03000SO 
S0300060 
S0300070 
S0300080 
S0300090 
S0300100 
S0300110 
S03Q0120 
S0300130 
S03C0140 
S03001S0 
S0300160 
S0300170 
S0300180 
S0300190 
S0300200 
S0300210 
S0300220 
S0300230 
S0300240 
S03002S0 
S0300260 
S0300270 
S0300280 
S0300290 
S0300300 
S0300310 
S0300320 
S0300330 
S0300340 
S03003S0 
S0300360 
S0300370 


TAB , TAB 2 , S ETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRD SP,S0300380 


CLRLNE , INSLNE , DEL INE , 

IESCAJ(3) ,NULL,IBLNK, 

IPAR(S) , ICU, lYSJ , lYESJ, INJ, INOJ,NAMEP(3) 

C VEHICLE PAPJU^IETERS 

COMMON /VCLPR/ VPAR(17) 

C time PARAMETERS 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, 

LD AY , LYE AR , I SMON ( 2 ) , JMON ( 2 ) , LMON ( 2 ) , LSDT ( 2 ) 

C SOUND ING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , 
RH(30) ,PTEMP(30),SIGEP(30) ,SIGAP(30) 

C LAYER PARAMETERS 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , 


S0300390 

S0300400 

S0300410 

S0300420 

S0300430 

S0300440 

S03G04S0 

S0300460 

S0300470 

S0300480 

S0300490 

S0300500 

S0300S10 
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SIGYO(29) S0300520 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S0300530 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S03005A0 

C CALCULATED .NEW LAYER PARAl-IETERS S0300550 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,80300560 
SPEEDN(32) S0300570 

C CONVERSION FACTORS S0300580 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S0300590 

C S0300600 


C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S03006 10 


COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S0300620 

C READ/WRITE BUFFER S0300630 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S0300640 




c 

c EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(D) , (lOU, IPAR(2) ) , (iPUl , IPAR(3) ) 

, (IPU2,IPAR(4)) , (IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) 

C 

C**** END OF COMMON AREA 

Cc 
c 
c 

c SITE-SPECIFIC DATA STATEMENT. 

DATA LOCATN /2HKS.2HC / 

DATA RUNNUM /!/ 

C 

C 

C REVISION NUMBER DATA STATEMENT. 

DATA IVERSN /8213/ 

C 

C 

C 

DATA MINUS1,MINUS9,MINS1,MINS9 /2H-1 , 2H-9,-l ,-9/ 

DATA IYSJ/1HY/,IYESJ/2HYE/,INJ/1HN/,IN0J/2HN0/,NAMEP/3*1H / 
DATA NNNEST /-!/ 

DATA TERROR /5*0/ 

DATA NCOM(l) ,NTOTAL(l) /2077.3569/ 

DATA NULL/O/ 

DATA PLUS(745)/-9925.0/ 

C 


S0300660 

S0300670 

S0300680 

S0300690 

S0300700 

S0300710 

****50300720 

S0300730 

S0300740 

S0300750 

S0300760 

S0300770 

S0300780 

S0300790 

S0300800 

S0300810 

S0300820 

S0300830 

S0300840 

S0300850 

S030C860 

S0300870 

S0300880 

S0300890 

S0300900 

S0300910 

S0300920 

S0300930 


DATA PI,G,CP,MAXLEV,GAMMAI,GAMMAC /3. 141593.9.8.0.24,30.0.64,0.50/80300940 


C S0300950 

DATA ALTSET.OFF.BLNKNG.INV.TNVHF.ULINE.INVNDR S0300960 

1 /15451B,40400B,15446B,62100B,15446B,62101B, S0300970 

2 15446B,62102B,15446B,62112B,15446B,62104B,15446B,62106B/ S0300980 

DATA TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , CLRLNE , SO 3 009 90 

1 INSLNE, DELINE /1 1B.44 1 IB, 15461B, 15462B, 15501B, 15502B, 15504B, S0301000 

2 15512B.15513B,15514B,15515B/ S0301010 

DATA lESCAJ /015501B,015512B, 1H_/, IBLNK /2H / S0301020 

C S0301030 
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I il III 



DATA RT/2H 0, 2HPE , 2HRA, 2HTT , 2H0N, 2HAL, S0301040 

2H ,2H ,2HRE,2HSE,2HAR,2HCH, S0301050 

2H ,2HPR,2HOD,2HUC,2HTI,2HON, S0301060 

2H ,2HDI,2HAG,2HNO,2HST,2HIC/ S0301070 

DATA CL/2K , 2H , 2H ,2H S,2HUR,2HFA,2HCE, S0301080 

2H S,2HTA,2HBI,2HLI,2HZA,2HTI,2HON/ S0301090 

DATA CS/2HEL,2HLI,2HPT,2HIC,2HAL, S0301100 

. 2H S,2HPH,2HER,2HIC,2HAL/ S0301U0 

END S0301120 
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SUBROUTINE IFNBR ( IBUF , NCHAR , lER , LU) 

DIMENSION IBUF(40) , JBUF(80) , JCHAR(ll) 

DATA JCHAR/IH , IH. , IH, , 1H-, 1H+, IHE, IH/ , IHO, 1H9, IHA, IHZ/ 

IF (NCILAR .EQ. -1) GO TO 20 
IF (NCHAR .LT. 0) GO TO 30 
DO 10 1=1 ,40 
10 IBUF(I) = JCHAR(l) 

20 READ (LU,9001) IBUF 
30 CALL CODE(80) 

READ (IBUF, 9002) JBUF 
lER = 1 

N = TABS (NCHAR) 

I = ITLCG(L) 

IF (I .LT. N) N = I 
IF (NCHAR- .EQ. -1) N = 4 
DO 50 L=1,N 
DO 40 1=1,7 

C CHECK FOR SPECIAL CHARACTER, PART OF NUMERIC DATA 
IF (JBUF(L) .EQ. JCHAR(D) GO TO 50 
40 CONTINUE 

C CHECK FOR NUMERIC VALUE 

IF (JBUF(L) .GE. JCHAR(8).AND.JBUF(L) .LE. JCHAR(9)) GO TO 50 
GO TO 80 
50 CONTINUE 
lER = 0 

IF (NCHAR .NE. -1) GO TO 80 
lER = 1 
DO 70 1=6,20 

IF (I.EQ.9.0R.I.’EQ. 12.0R.I.EQ. 16) GO TO 70 
IF (JBUF(I) .EQ. JCHAR(l)) GO TO 70 
IF (I.GE.6.AND.I.LE.8) GO TO 60 
IF (I.GE. 13.AND.I.LE. 15) GO TO 60 
C CHECK FOR NUMERIC VALUE 

IF (JBUF(I) .GE. JCHAR(8).AND.JBUF(I) .LE. JCHAR(9)) GO TO 70 
GO TO 80 

C CHECK FOR ALPHABETIC VALUE 

60 IF (JBUF(I) .GE. JCHAR(IO) .AND. JBUF(I) .LE. JCHAR(ll)) GO TO 70 
GO TO 80 
70 CONTINUE 
lER = 0 
80 RETURN 

9001 FORMAT (40A2) 

9002 FORMAT (80Al) 

END 


S0400000 

S0400010 

S0400020 

S0400030 

S0400040 

S0400050 

S040C060 

S0400070 

S0400080 

S0400090 

S0400100 

S0400110 

S0400120 

S0400130 

S0400140 

S0400150 

S0400160 

S0400170 

S0400180 

S0400190 

S0400200 

S0400210 

S0400220 

S0400230 

S0400240 

S0400250 

S0400260 

S0400270 

S0400280 

S0400290 

S0400300 

S0400310 

S0400320 

S0400330 

S0400340 

S0400350 

S0400360 

S0400370 

S0400380 

S0400390 

S0400400 

S0400410 

S0400420 

S0400430 


I 

I 
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REEDM SOURCE MODULE &READM 


S0500000 
S0500010 
S0500020 
S0500030 
S0500040 
S0500050 
S0500060 
S0500070 
S0500080 
S0500090 
S0500100 
S0500110 
S0500120 
S0500130 
S0500140 
S0500150 
S0500160 
S0500170 
S0500180 
S0500190 
S0500200 
S0500210 
S0500220 
S0500230 
S0500240 


C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


FTN4 

PROGRAM REALM (5) 

, , UPDATE: 8213 SOURCE 


02 APR 82 LOCATION: KSC 


ORGANIZATION: H. E. CRAMER CO., INC. 

WORK FOR: DR. J. B. STEPHENS (ES84) 

PROGRAM CODE: REEDM 

PROGRAM DESCRIPTION: , INPUT USER DATA FOR ROCKET EXHAUST 

EFFLUENT DIFFUSION ANALYSIS 
(MULTI-LAYER) 

INPUT: USER SPECIFIED OPTIONS 

OUTPUT: PRINTED AND DISPLAYED LISTING OF USER INPUT VALUES 


C**** BEGIN COMMON AREA 

04/02/82 

MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 
C INPUT OPTIONS 


REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 
IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,BOTLAY, 

. ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE (3 ) 

. , RA INRT , LAMBDA , TIMl , DURAT , NVS , I VERSN , LOCATN ( 2 ) 

. ,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DIS0(10) , 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20),MDLNAM(12),DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL I SNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

. MODEL4,MODEL5,MODEL6 

INTEGER RUNNUM , RT , CL , C S 

COMMON /CTRFL/ IFLG, RUNNUM, NUM,NLAYS,NBK,QC,QT, HEAT, ZM,H,. 

. DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

. SIGZ, ISNDFO, CRT, LAYTOP(3),ITDU, KEEP 

, MIXING , MAXDEP , LAYBOT (3 ) 

• .ALTSV, BATCH, CL(14),CS(10) , GASSET, lAGAIN, 


****S0500250 

S0500260 

S0500270 

S0500280 

S0500290 

S0500300 

S0500310 

S0500320 

S0500330 

S0500340 

S0500350 

S0500360 

S0500370 

S0500380 

S0500390 

S0500400 

S0500410 

S0500420 

S0500430 

S0500440 

S0500450 

S0500460 

S0500470 

S0500480 

S0500490 
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ICHAR(12) ,IDXCL,IDXCS,IERROR(5),IFR>IT(80), S0500500 

. MINUS 1,MINUS9, MINS 1,MINS9, S0500510 

M0DEL4, MODELS, MOD EL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S0500520 
RT(24) ,TPROPC,IDXRT S0500530 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT MLTIBERS. S0500540 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S0500550 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S0500560 

CLRLNE INSLNE, DELINE S0500570 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S0500580 

INVNDR(2) ,ULINE(2) , S0500590 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN, CURLFT , CLRDSP , S0500600 
CLRLNE, INSLNE, DELINE, S0500610 

IESCAJ(3) ,NULL,IBLNK, S0500620 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S0500630 

C VEHICLE PARAMETERS S0500640 

COMMON /VCLPR/ VPAR(17) S0500650 

C TIME PARAMETERS S0500660 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S0500670 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S0500680 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S0500690 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S0500700 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S0500710 

Q LAYER PARAMETERS S0500720 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) . SIGXO(29) , S0500730 

. SIGYO(29) S0500740 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S0500750 

COMMON /BLAYR/ DIRB (6) , SPEEDB (6) ,TEMPB (6) S0500760 

C CALCULATED NEW LAYER PARAJIETERS S0500770 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,50500780 
SPEEDN(32) S0500790 

C CONVERSION FACTORS S0500800 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S0500810 

S0500820 

C**********COMMOM BUFFER ARRAY FOR COMMON MODIFICATION******************S0500830 
COMMON /EXTRA/ NCOM(l), NTOTAL(l). PLUS(900) S0500840 

C READ/WRITE BUFFER S0500850 

Q ^ R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S0500860 

C***********************************************************************S0500870 

S0500880 

C EQUIVALENCE STATEMENTS S0500890 

EQUIVALENCE(IIU,IPAR(1)) , (IOU,IPAR(2)) , (IPU1,IPAR(3)) S0500900 

,(IPU2,IPAR(4)),(IPU3,IPAR(5)) S0500910 

EQUIVALENCE (MAXDEP, GRVSET) , ( IFRMT ( 1 ) , IFRMT 1 ) S0500920 

EQUIVALENCE (IDCB(iLfLUS( 1)) , (INPT(l) ,PLUS(73)) S0500930 

^ S0500940 

C**** END OF COMMON AREA ****50500950 

S0500960 

CF INPUT FORMAT STATEMENTS S0500970 

9001 FORMAT (40A2) 

9002 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2.6H REC. S0500990 

*,I2.1H.,I2/) S0501010 

9003 FORMAT (2A2,A1) bUDUiuiu 
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9004 FORi-IAT (14 , 2A2 , 1X12 , 1XA2 ,A1 , 1X14) S0501020 

9005 FORl-lAT (39H *** REEDM ERROR 004, CANNOT FIND FILE ,7A2) S0501030 

9006 FOR>IAT(20A1) 5050 1040 

9007 FORMAT (41H *** REEDM WARNING 005, CANNOT FIND FILE ,7A2,20H FOR LS0501050 

*AUNCH TIME AND/34H DATE, USING CURRENT TIME AND DATE/) S0501060 

9008 FORMAT (44H *** REEDM WARNING 006, UNABLE TO OPEN FILE ,7A2,20H FOS0501070 

*R LAUNCH TIME AND/34H DATE, USING CURRENT TIME AND DATE/) 3050 1080 

CF OUTPUT FORMAT STATEMENTS SOSO 1090 

9009 FORMAT(40H GRAVITATIONAL SETTLING CATEGORIES DATA) S0501100 

9010 F0RMAT((6X,9(F5.4,1H,),F5.4)) S0501110 

9011 FORl-IAT (lX,32(2H**)hx,3'(2H**),5X,42HNASA/MSFC MULTIPLE LAYER TECS0501120 

IHNIQUE - REEDM, 5X, 3(2H**)/1X, 3(2H**) ,12X,6KUPDATE, 15, 14H LOCATIS0501130 
20N ,2A2,12X,3(2H**)) _ S0501140 

9012 F0R>L4T(1X,3(2H**) ,5X,42HEnter to change previous input value. S0501 150 

1 , 5X, 3 (2H**) /IX, 3 (2H**) , 5X, 44HEnter '-9' to start at beginning of pS0501160 
2rograra. ,3X,3(2H**)/1X,3(2H**) ,5X,41HEnter '-9' at beginning to aboS0501170 
3rt program. ,6X,3(2H**)) S0501180 

9013 F0RMAT(1X,3(2H**),15X,21HBATCH MODE DATA INPUT, 16X,3(2H**) / S0501190 

1 1X,32(2H**)/) S0501200 

9014 FORMAT ( IX, 3 (2H**) ,5X ,43Hthe first input option shown is the defauS0501210 

llt,4X,3(2K**)) S0501220 

9015 FORMAT (48H AVERAGE PARTICLE SIZE DIAMETERS (MICROMETERS) =, S0501230 

1 12X,F5.2) S0501240 

9016 FORMAT (6H ENTER, 13, 47H AVERAGE PARTICLE SIZE DIAMETERS (MICROMETERS0501250 

IS):) S0501260 

9017 FORMAT(6H ENTER, 13, 45H REFLECTION COEFFICIENT (NO REF. = 0) VALUESSO5O1270 

1:) S0501280 

9018 FORMAT(33H FREQUENCY OF OCCURRENCE VALUES =,27X,F5.4) 3050 1290 

9019 FORMAT(6H ENTER, 13, 53H FREQUENCY OF OCCURRENCE VALUES (SUM MUST TOS0501300 

ITAL 1.0):) S0501310 

9020 FORMAT(73H *** REEDM WARNING 007, FREQUENCY OF OCCURRENCE VALUES DS0501320 

10 NOT SUM TO 1.0, /35H TYPE "N" - RETURN TO NORMALIZE BY ,F8.5, S0501330 

23 2H OR SPACE - RETURN TO CONTINUE:_) S0501340 

9021 FORMAT ( IX, 32 (2H**) /) S0501350 

9022 FORMAT (12, 1X,I2, 11X,I2,2X,A2,A1 ,3X,I4) S0501360 

9023 FORMAT (78K *** REEDM WARNING 008, A CALCULATION HEIGHT II 5 METERSS0501370 

* WILL PRODUCE ERRONEOUS/18H RESULTS FOR AL203//) S0501380 

9024 FORMAT (55H DO YOU WISH TO ENTER A DIFFERENT CALCULATION HEIGHT? (S0501390 

*,2A2, 1HY,2A2,2HES,2A2, IH, ,2A2,1HN,2A2,4H0) :_) S0501400 

9025 FORMAT (//////////////////////5A2) S0501410 

9026 FORMAT(17H ENTER RUN TYPE ( , 2A2, 1110, 2A2 , lOHPERATIONAL, 2A2 , IH, , 2A2 , S0501420 

*1HR,2A2,8HESEARCH, ,2A2,1HP,2A2,12HR0DUCTI0N):_) S0501430 

9027 FORMAT ( 2A2, 1 OH RUN TYPE: , 43X, 6A2) S0501440 

9028 FORMAT(38H ENTER METEOROLOGICAL DATA FILE NAME (,7A2,3H):_) S0501450 

9029 FORMAT(2A2,31H METEOROLOGICAL DATA FILE NAME: , 28X, 3A2) S0501460 

9030 FORMAT(34H ENTER NUMBER OF RUNS TO BE MADE ( , 2A2 . 12 , 2A2 , 3H) :_) S0501470 

9031 FORMAT(2A2,27H NUMBER OF RUNS TO BE MADE: , 34X, 14) S0501480 

9032 F0RMATO9H ENTER MODEL TYPE (,2A2, 1HC,2A2, 17HONCENTRATION/DOS. ,2A2S0501490 

* , IH , , 2A2 , IHW, 2A2 , 1 2HASHOUT DEP . , , 2A2 , IHG , 2A2 , 20HrwVVITATIONAL DEP. ) 5050 1500 
*:_) S0501510 

9033 FORMAT (2A2,12H MODEL TYPE : , 29X, 12A2) S0501520 

9034 FOPMAT(29H ENTER LAUNCH TIME AND DATE ( , 2A2 , 14 ,2A2 , IX, 12 , 1X,A2 , A1 , S0501530 
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*1X,I4,2A2,2H): ,23A2,1H_) S0501540 

9035 FORMAT (23H *** REEDM WARNING 009,/ S0501550 

*40H INVALID MONTH ENTERED - PLEASE RE-ENTER, 12A2 , 1H_) S0501560 

9036 FORMAT ( 3A2 , 2 2H LAUNCH TIME AND DATE: ,23X, 14, 2A2, 1X12, 1XA2,A1 , 1X14)50501570 

9037 FORMAT(23H ENTER LAUNCH VEHICLE ( , 2A2 , IHS , 2A2 , 6HHUTTLE, 2A2 , IH , , 2A2S050 1580 

*, 1HT,2A2,5HITAN, ,2A2, 1HD,2A2,4HELTA,2A2, 1H2,2A2,4H914, ,2A2, 1HD,2A2S0501590 
*,4HELTA,2A2,1H3,2A2,6H914) :_) S0501600 

9038 FORMAT { 2 A2,16H LAUNCH VEHICLE: , 35X, 7A2) S0501610 

9039 F0RMAT(20H ENTER LAUNCH TYPE (,2A2, 1HN,2A2,5H0R1-IAL,2A2, IH, ,2A2, 1HSS0501620 

___ . \ 


*,2A2,13HINGLE ENGINE, , 2A2 , IHC, 2 A2 , ISHONFLAGPvATION) :_) 
9040 FORMAT ( 2A2, 13H LAUNCH TYPE: , 38X, 7A2) 


S0501630 

S0501640 


9041 FORMAT(45H ENTER PROPELLANT TEMPERATURE (30 DAY AVG.) (,2A2,F5.2, S0501650 


*2A2,10H DEG. C) :_) 

9042 FORMAT(2A2,33H PROPELLANT TEMPEPJ^TURE (DEG. C) : , 24X,F8. 2) 

9043 FOPvMAT(28H ENTER ONE OR MORE SPECIES ( , 2A2 , IHH, 2A2 , 2HCL, 2A2 , IH, , 
*2A2 , IHA, 2A2 , 5HL203 , , 2A2 , IKC, 2A2 , IHO, 2A2 , 1H2 , 2A2 . IH, , 2A2 , IHC, 2A2 , 
*4H0) :_) 

9044 F0RMAT(2A2,9H SPECIES :, 32X, 1 2A2) 

9045 F0RMAT(31H ENTRAINMENT PARAMETERS GAMMAX=,F3. 2,8H GAMMAY=,F3. 2, 
*8H GAMMAZ= , F3 . 2 , 9H CHANGE ( , 2A2 , IHN, 2A2 , IHO, 2A2 , IH, , 2A2 , IHY, 2A2 , 
*5HES) :_) 

9046 FORMAT (2A2, 5 OHTHE PRODUCT OF GA>MAX*GAMMAY*GAMMAZ SHOULD EQUAL , 
*F3.2,6H CUBED) 


S0501660 

S0501670 

S0501680 

S0501690 

S0501700 

S0501710 

S0501720 

S0501730 

S0501740 

S0501750 

S0501760 

S0501770 

S0501780 

S0501790 


9047 FORMAT ( 2A2, 15H ENTER GAMMAX ( , 2A2 ,F3 . 2 , 2A2 ,3H) :_) S0501770 

9048 FORMAT ( 2A2, 15H ENTER GAMMAY (,2A2,F3.2,2A2,3H) :_) S0501780 

9049 FORMAT (2A2,15H ENTER GAMMAZ ( , 2A2 ,F3 . 2 , 2A2 ,3H) :_) S0501790 

9050 FORILXT (75H *** REEDM WARNING 010, THE PRODUCT OF THE GAMMA'S IS IS0501800 

*NCORRECT, CONTINUE? /2H ( , 2A2 , IHY, 2A2 , 2HES,2A2 , IH, , 2A2 , IHN, 2A2 , S0501810 

*4H0) : ) S0501820 

9051 FORMAT(2A2,32H ENTRAINMENT PARAMETERS GAMMAX= , F4 . 2 , 8H GAMMAY=, S0501830 

*F4.2,8H GAMMAZ=,F4.2) S0501840 

9052 F0RMAT(30H ENTER LAUNCH COMPLEX NUMBER (,2A2,3H39A,2A2, IH, ,2A2, S0501850 

*3H39B,2A2, IH, ,2A2,3H39C,2A2, IH, ,2A2,2H40,2A2,1H, ,2A2,2H41 ,2A2, IH, ,50501860 

*2A2,2H17,2A2,3H) :_) S0501870 

9053 F0RMAT(2A2,43H PLEASE CONFIRM - IS LAUNCH COMPLEX NUMBER ,A2,A1, S0501880 

*6H OK? (,2A2,1HY,2A2,2HES,2A2,1H,,2A2,1HN,2A2,4H0):_) S0501890 

9054 FORMAT (2A2,23H LAUNCH COMPLEX NUMBER: ,39X,A2,A1) S0501900 

9055 FORMAT(30H CALCULATIONS TO BE DONE AT? ( , 2A2, IHS, 2A2 .6HURFACE, 2A2 , S0501910 

* IH, , 2A2 , 2HST , 2A2 , 1 2HABILIZATION, , 2A2 , IHA, 2A2 , 9HNOTHER) :_) S050 1 920 

9056 FORMAT (2A2, 2 8H CALCULATIONS TO BE DONE AT:,23X,7A2) S0501930 

9057 FORMAT (2A2,36H ENTER CALCULATION HEIGHT (METERS) ( , 2A2 ,F8. 2 , 2A2 , S0501940 

*10H METERS); ) 

9058 FORMAT (2A2,37H CALCULATIONS TO BE DONE AT (METERS) :, 20X,F8. 2) S0501960 

9059 FORMAT (19H ENTER CLOUD SHAPE (, 2A2, 1HE,2A2,9HLLIPTICAL,2A2, IH, ,2A2,S050 1970 

*1HS,2A2, IIHPHERICAL) ;_) S0501980 

9060 FORMAT (2A2,13H CLOUD SHAPE: ,42X,5A2) S0501990 

9061 FORMAT(57H ENTER ABSORPTION COEFFICIENT FOR GASES ONLY (RNG:0 TO 1S0502000 


S0501950 

S0501960 


* , ,2A2, 16HDEF. = NO ABS . =0 , 2A2 , 3H) :_) 

9062 FOR>L\T(2A2,24H ABSORPTION COEFFICIENT: , 37X,F4. 2) 


S0502010 

S0502020 


9063 FORMAT(26H ENTER DECAY COEFFICIENT (,2A2,10HNO DECAY=0 , 2A2 , 3H) ;_) S0502030 


9064 F0R1L\T(2A2, 19H DECAY COEFFICIENT; ,42X,F4. 2) 

9065 FORMj\T(31H DIFFUSION COEFFICIENTS ALPHA= , F3 . 1 , 6H BETA=,F3.1. 


S0502040 

S0502050 
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*9H CHANGE ( , 2A2 , IHN, 2A2 , IHO, 2A2 , IH, , 2A2, IHY, 2A2 ,5HES) :_) S0502060 

9066 FORMAT ( 2 A2.15H ENTER ALPHA:_) S0502070 

9067 FORMAT ( 2 A2, 14H ENTER BETA:_) S0502080 

9068 FORMAT (2A2.24H DIFFUSION COEFFICIENTS: ,28X,6HALPHA=,F4. 2, 6H BETA= , S0502090 

*F4.2) S0502100 

9069 FORMAT(34H DOWNWIND EXPANSION DISTANCES XRY=,F5.1,5H XRZ=,F5.1, S0502110 

*9H CHANGE ( , 2A2 , IHN, 2A2 , IHO, 2A2 , IH, , 2A2 , IHY, 2A2 ,5HES) :_) S0502120 

9070 FORMAT ( 2 A2,12H ENTER XRY:_) S0502130 

9071 FORMAT ( 2 A2,12H ENTER XRZ:_) S0502140 

9072 FORMAT ( 2 A2, 3 OH DOWNWIND EXPANSION DISTANCES: ,20X,4HXRY= ,F8 . 2 , S0502150 

*5H XRZ=,F8.2) S0502160 

9073 F0RMAT(2A2,44H DISTANCE FROM PAD TO SIGXO MEASUREMENT PT.:,15X, S0502170 

*F8.2) S0502180 

9074 F0RMAT(38H CONCENTRATION AVERAGING TIME (TIMAV=,2A2,F5. 1 ,2A2, S0502190 

*15H SEC.) CHANGE ( , 2A2 , IHN, 2A2 , IHO, 2A2 , IH, , 2A2 , IHY, 2A2 ,5HES) :_) S0502200 

9075 FORMAT(2A2,14H ENTER TIMAV:_) S0502210 

9076 FORMAT (2A2, 3 6H CONCENTRATION AVERAGING TIME (SEC) : ,21X,F8. 2) S0502220 

9077 FORMAT(32H NUMBER OF SETTLING CATEGORIES =,30X,I3/52H TERMINAL FALS0502230 

*L VELOCITY VALUES (METERS PER SECOND) =,8X,F5.4) S0502240 

9078 FORMAT (56H DO YOU WISH TO CHANGE THE GRAVITATIONAL SETTLING DATA (S0502250 

*, 2A2 , IHN, 2A2 , IHO, 2A2 , IH, , 2A2 , IHY, 2A2,5HES) :_) S0502260 

9079 FORMAT (2A2, 5 3H ENTER THE NUMBER OF SETTLING CATEGORIES (MAXIIRJM ISS0502270 

* ,I2,3H):_) S0502280 

9080 FORMAT (2A2,6H ENTER, 13, 5 2H TERMINAL FALL VELOCITY VALUES (METERS PS0502290 

*ER SECOND) :_) S0502300 

9081 FORMAT(32H REFLECTION COEFFICIENT VALUES =,28X,F5.4) S0502310 

9082 FORMAT(28H ENTER ONE OR MORE SPECIES (,2A2, 1HH,2A2,2HCL,2A2, IH, , S0502320 

*2A2,1HA,2A2,7HL203):_) S0502330 

C TYPE AND DIMENSION STATEMENTS S0502340 

INTEGER M0NTHS(24),LV(28),LT(21),SP(12),LC(12) S0502350 

DIMENSION VPARS(17,5) ,LMODEL(12,3) ,IDCB(144) ,NAMF(3) S0502360 

DIMENSION INPT(IO) ,AVTMP(12) S0502370 

DIMENSION VSDEF(20) ,FSDEF(20) ,GAMDEF(20) ,DBRDEF(20) S0502380 

DIMENSION NDX(2) S0502390 

C S0502400 

EQUIVALENCE (INPT(l) , INPTI) S0502410 

C data statements S0502420 

C VPARS( i-17)=SHUTTLE (18-34)=TITAN (35-51)=DELTA 2914 S0502430 

C (55-72)=DELTA 3914 (73-90)=MINUTEMAN S0502440 


ORDER OF DATA IS: QCl ,QC2,QC3,QT1,QT2,QT3,A,B,C,HEATN,HEATM, S0502450 

HEATA,HCL%,C02%,C0%,AL203% S0502460 

DATA VPARS/1. 521923E7, 3. 84505682E6, 9. 88726071 1E5,1. 251 174E9, S0502470 

5. 075475E8,1.015095E9,. 6522129891,. 4680846, S0502480 

.375,1479.7,1062.35, 1000 . 0 , . 1 146 , . 25029 , . 00042 ,.18279, S0502490 
.0002, S0502500 

5.437528E6,2.718764E6,1.359382E6,3.2625168E8, S0502510 

1. 6312584E8, 3. 2625168E8,. 429580469,. 5184223, S0502520 

5. 0. 2021. 1.1010. 55. 1000.0.. 1932.. 2665.. 0222, S0502530 

,2819, .0002, S0502540 

8.360685E5,9.09811E4,2.729434E5,2.887598E7, S0502550 

3. 14229E6,1.885373E7,. 922156,. 432703,. 54, 1766.0, S0502560 

1000.0. 690.0.. 1218.. 2055.. 0156.. 2214.. 0002, S0502570 
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1.057557E6,1.482923E5,3.70731E5,6.70269E7, S0502580 

9. 3986 16E6, 4. 699308E7, 1.245756,. 4180947, S0502590 

0.0,1449.9,1000.0,411. 18,. 1589,. 2783,. 0331,. 1936, S0502600 

.0002, S0502610 

4.684476E5,4.684476E5,1. 171119E5,2.8106856E7, S0502620 

2.8106856E7,2.8106856E7,.469982,.463333,0.0, S0502630 

2055.9,2055.9,1000.0,. 1866, . 2055, .0156, . 3391 , S0502640 

.0002/ S0502650 

DATA AVTMP/16.06,19.59,20.87,23.43,25.74,27.67, S0502660 

28.38,28.63,28.02,26.29,22.86,18.68/ S0502670 

DATA M0NTHS/2HJA,1HN,2HFE,1HB,2HMA, IHR, 2HAP , IHR, 2HMA, IHY, 2HJU, IHN , S0502680 
2HJU, IHL, 2HAU, IHG, 2HSE, IHP, 2HOC, IHT, 2HNO, IHV, 2HDE, 1HC/S0502690 


DATA LV/2K 

S,2HPA 

,2HCE,2H S,2HHU,2HTT,2HLE, 

S0502700 

2H 

,2H 

,2H T,2HIT,2KAN,2H I,2HII, 

S0502710 

2H 

,2H 

,2HDE,2HLT,2HA ,2H29,2H14, 

S0502720 

2H 

,2H 

,2HDE,2HLT,2HA ,2H39,2H14/ 

S0502730 

DATA LT/2H 

,2H 

,2H ,2H ,2HNO,2HRM,2HAL, 

S0502740 


2H S,2HIN,2HGL,2HE , 2HEN, 2HGI , 2HNE, S0502750 

2H C,2HON,2HFL,2HAG,2HRA,2HTI,2HON/ S0502760 

DATA SP/2H ,2H H,2HCL, S0502770 

2H ,2H C,2H02, S0502780 

2H ,2H ,2HCO, S0502790 

2H A,2HL2,2H03/ S0502800 

DATA LC/2H39,1HA,2H39,1HB,2H39,1HC,2H40,1H ,2H41,1H ,2H17,1H / S0502810 

DATA LMODEL/2H ,2H ,2HCO,2HNC,2HEN,2HTR,2HAT,2HIO,2HN/, S0502820 

1 2HDO,2HSA,2HGE, S0502830 

2 2H ,2H ,2H , 2TOA, 2HSH, 2HOU, 2HT ,2HDE,2HPO, S0502840 

3 2HSI,2HTI,2HON, S0502850 

4 2HGR,2HAV,2HIT,2HAT,2HIO,2HNA,2HL ,2HDE,2HPO, S0502860 

5 2HSI,2HTI,2HON/ S0502870 

DATA NVSDEF,VSDEF,GAMDEF,FSDEF S0502880 

1 /10,10*. 1078, 10*0. 0,20*0.0,. 0002,. 0151,. 1182,. 1175,. 1724,. 2358, S0502890 

2 .3130, .4240, .5818, .7266,10*0.0/ S0502900 

DATA DBRDEF / 1 15 . , 230 . , 350 . ,440 . , 500. ,555 . , 610. ,675 . , 750 . ,870 . , S0502910 

1 10*0.0/, MAXNVS /lO/ S0502920 

DATA IHO/ IHO/ , IHP/ IHP/ , IHR/ IHR/ , IHD/ IHD/ , IHl / IHl/ , IHC/IHC/ , S0502930 

* IHW/ IHW/ , IHG/ IHG/ , IHS/ IHS/ , IHT/ IHT/ , IHCMA/IH, / , IHA/IHA/ , S0502940 

* IHH/1HH/,IHL/1HL/,IH2/1H2/,IH3/1H3/,IHM/1HM/,IHE/1HE/, S0502950 

* IHB/1HB/,IHN/1HN/ S0502960 

DATA IIH0P/2H0P/ , IIHPR/2HPR/ , IIHRE/2HRE/ , IIHDI/2HDI/ , IIHCO/2HCO/ , S0502970 

* IIHWA/2HWA/,IIHGR/2HGR/,IIHSH/2HSH/,IIHTI/2HTI/,IIHD2/2HD2/, S0502980 

* IIHD3/2HD3/ , IIHSI/2HSI/ , IIHST/2HST/ , IIHSU/2HSU/ , IIHAN/2HAN/ , S0502990 

* IIHEL/2HEL/,IIHSP/2HSP/,IIHMA/2HMA/,IIHHE/2HHE/,IIHMO/2HMO/, S0503000 

* IIHLI/2HLI/,IIHTA/2HTA/,IIHPE/2HPE/,IIHDA/2HDA/,IIHBE/2H E/, S0503010 

* IIHBP/2H P/,IIHRR/2HRR/,IIHSO/2HSO/,IIHND/2HND/ S0503020 

DATA IESA/15501B/,IESJ/15512B/, S0503030 

* IESE/15505B/,IESH/15510B/,IESP/15451B/,IESD/15504B/, S0503040 

* IESB/15502B/,INVBL/62103B/,IAUN/2HA_/ S0503050 

DATA NAMF/2H?L,2HTI,2HME/ S0503060 

DATA NDX/2*1H / S0503070 

DATA JVERSN/8213/ S0503080 
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c 

IF (IVERSN .NE. JVERSN) CALL L0ADS(-1 ,0,0, 0,0, BATCH) 

IF (CRT) GO TO 10 
I ESA = NULL 
lESJ = NULL 
lESE = NULL 
lAUN = IBLNK 
lESH = NULL 
lESP = NULL 
lESD = NULL 
lESB = NULL 
INVBL = NULL 
10 CONTINUE 

DETERMINE ENTRY POINT. 

NNNEST = 2 

GOTO (20,2390,2390,2390,1620,2050,2140,1430,1530), NNNTRY 


INITIALIZE SOME INPUT VARIABLES 
20 CONTINUE 
IFLG=0 
ALPHA=1.0 
BETA=1.0 
DECAY=0.0 
TIMAV=600.0 
XRY= 100.0 
XRZ= 100.0 
XLRY=0.0 
CALHT=0.0 
ICALC = 1 
LSITE=0 

C DEFAULT DATA FILE NALIE 

FILE(1)=IIHRR 
FILE(2)=IIHSO 
FILE(3)=IIHND 
NUMRUN=1 
IAGAIN=0 
TIMl =0.0 
RAINRT =0.3 
DURAT =1.0 
NVS = 10 
DO 30 1=1, NVS 
30 VS(I) = VSDEF(I) 

C DEFAULT ABSORPTION COEFFICIENT FOR GASES. 

GAMMAP(21) =0.0 

C DEFAULT REFLECTION COEFFICIENT, FRACTION OF MATERIAL, DROP SIZE 

C FOR AL203. 

DO 40 1=1, NVS 
GAMMAP(I) = GAMDEF(I) 

FS(I) = FSDEF(I) 

40 DBAR(I) = DBRDEF(I) 


S0503100 

S0503110 

S0503120 

S0503130 

S0503140 

S0503150 

S0503160 

S0503170 

S0503180 

S0503190 

S0503200 

S0503210 

S0503220 

S0503230 

S0503240 

S0503250 

S0503260 

S0503270 

S0503280 

S0503290 

S0503300 

S0503310 

S0503320 

S0503330 

S0503340 

S0503350 

S0503360 

S0503370 

S0503380 

S0503390 

S0503400 

S0503410 

S0503420 

S0503430 

S0503440 

S0503450 

S0503460 

S0503470 

S0503480 

S0503490 

S0503500 

S0503510 

S0503520 

S0503530 

S0503540 

S0503550 

S0503560 

S0503570 

S0503580 

S0503590 

S0503600 

S0503610 
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KEEP = 0 

WRITE THE HEADER OF THE CONSOLE 

WRITE(ICU,9025) lESE , lESH, lESJ, lESP, lAUN 
WRITE(ICU,9011) IVERSN.LOCATN 
IF (BATCH) GO TO 50 
WRITE (ICU, 9012) 

IF (.NOT. CRT) WRITE (ICU, 9014) 

WRITE (ICU, 9021) 

50 CONTINUE 

IF(BATCH) WRITE(ICU,9013) 

run TYPE - OPER. (=2) ,RESRCH(=3) .PROD. (=1) ,DIAG. (=4) 

60 IF (BATCH) GOTO 70 

WRITE ( ICU , 90 2 6 ) INVNDR , INV , OFF , ULINE , OFF , ULINE , OFF 
70 INPTl = IBLNK 

READ(IIU,9001) INPTl 

IF (INPTl .EQ. MINUS 1. OR. INPTl .EQ. MINUS9) GO TO 2420 

IF UNPTl .EQ. IBLNK) INPTl = IHO 

IF aNPTl .EQ. IIHOP) INPTl = IHO 

IF (INPTl .EQ. IIHPR) INPTl = IHP 

IF UNPTl .EQ. IIHRE) INPTl = IHR 

IF (INPTl .EQ. IIHDI) INPTl = IHD 

IF (INPTl. EQ. IHO. OR. INPTl. EQ. IHP) GO TO 90 

IF (BATCH) GO TO 80 

IF (INPTl. EQ. IHR. OR. INPTl. EQ. IHD) GO TO 90 
80 WRITE (ICU, 9002) INV, OFF, 1,0 
IF (BATCH) GO TO 2420 
GO TO 60 
90 CONTINUE 
IDXRT=6 

CALL ANSW(1 ,INPT,IRUN,IDXRT,IER) 

IF(BATu: .AND. IRUN .LT. 1) IRL'N = 2 
IF(IRUN.LT.O) GO TO 2420 
IF(BATCH) GOTO 110 

WRITE(ICU,9027) IESA,IESJ, (RT(I) ,I=IDXRT,IDXRT+5) 

READ IN THE MET SOUNDING DATA FILE NAME 

USE FOUR CHARACTERS FOLLOWED BY TWO DIGITS 
100 WRITE(ICU,9028) INV, (FILE(I) ,1=1 ,3) .OFF 
110 READdIU, 9001) (INPT(I) , 1=1 , 3) 

IF (INPTl .NE. IBLNK) GOTO 130 
DO 120 I = 1,3 
120 INPT(I) = FILE(I) 

130 IF(BATCH) GOTO 150 

IFdNPTl .NE. MINUSl) GO TO 140 
WRITE(ICU,9003) lESCAJ.IESCAJ 
GO TO 60 

140 IFdNPTl .EQ. MINUS9) GOTO 20 
150 IPLACE = 0 

IF(INPT1.EQ.IIHTA.AND. INPT (2) .EQ.IIHPE) IPLACE = 2 
IF (INPTl. EQ.IIHDA. AND. INPT(2) .EQ. IIHTA) IPLACE = 1 
IF (IPLACE .NE. 0) GO TO 170 
CALL OPEN (IDCB.IER, INPT, 1) 

IF (lER .NE. -6) GO TO 160 


S0503620 

S0503630 

S0503640 

S0503650 

S0503660 

S0503670 

S0503680 

S0503690 

S0503700 

S0503710 

S0503720 

S0503730 

S0503740 

S0503750 

S0503760 

S0503770 

S0503780 

S0503790 

S0503800 

S0503810 

S0503820 

S0503830 

S0503840 

S0503850 

S0503860 

S0503870 

S0503880 

S0503890. 

S0503900 

S0503910 

S0503920 

S0503930 

S0503940 

S0503950 

S0503960 

S0503970 

S0503980 

S0503990 

S0504000 

S0504010 

S0504020 

S0504030 

S0504040 

S0504050 

S0504060 

S0504070 

S0504080 

S0504090 

S0504100 

S0504U0 

S0504120 

S0504130 
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raiTE (ICU,9002) INV,0FF,2,0 
WRITE (ICU,9005) INV, (INPT(I) , 1=1 ,3) ,OFF 
IF (BATCH) GO TO 2420 
GO TO 100 

160 CALL CLOSE (IDCB) 

170 CONTINUE 

IF(IPLACE.EQ.O) IPLACE=3 
180 DO 190 1=1,3 
190 FILE(I)=INPT(I) 

IF(BATCH) GOTO 200 

17RITE(ICU,9029) IESA,IESJ, (FILE(J) ,J=1,3) 

C READ THE NUMBER OF RUNS (PRODUCTION MODE ONLY) 

200 IFdRUN.NE. 1) GO TO 270 
IF(BATCH) GOTO 220 
210 WRITE(ICU,9030) INV , NUMRUN , OFF 
220 INPT1=IBLNK 

CALL IFNBR(IFRMT,10,IER,IIU) 

IF (lER .EQ. 0) GO TO 240 
WRITE (ICU.9002) INV, OFF, 3,0 
IF (BATCH) GO TO 2420 
GO TO 210 
230 INPTl = IHl 
240 CALL CODE (80) 

READ (IFRMT,*) INPTl 

IF (BATCH .AND, INPTl .LT. 1) INPTl = 1 
IF (INPTl .EQ, MINS9) GO TO 20 
IF (INPTl .EQ. MINSl) GO TO 250 
IF (INPTl .EQ. 0) INPTl = 1 
IF (INPTl .GT. 0) GO TO 260 
WRITE (ICU,9002) INV, OFF, 3,0 
IF (BATCH) GO TO 2420 
GO TO 210 

250 WRITE(ICU,9003)IESCAJ,IESCAJ 
GOTO 100 

260 IFdNPT.GT.O.AND.INPT.LT. 100) NUMRUN=INPT 
IF(BATCH) GOTO 290 
WRITE (ICU, 9031) IESA,IESJ, NUMRUN 
270 CONTINUE 

C MODEL TO BE USED 

IF(BATCH) GOTO 290 

280 WRITE(ICU,9032) INVNDR, INV,OFF,ULINE,OFF,ULINE,OFF 
290 INPTl = IBLNK 

READ(IIU,9001) INPTl 
IDXLV = 12 

300 IF (INPTl .EQ. IBLNK. OR. INPTl .EQ. IIHCO) INPTl = IHC 
IF (INPTl .EQ. IIHWA) INPTl = IHW 
IF (INPTl .EQ. IIHGR) INPTl = IHG 
IF (INPTl .EQ. MINUSl) GO TO 320 
IF (INPTl .EQ. MINUS9) GO TO 20 

IF (INPTl. EQ. IHC. OR. INPTl. EQ. IHW. OR. INPTl. EQ. IHG) GO TO 310 
WRITE (ICU, 9002) INV, OFF, 4,0 
IF (BATCH) GO TO 2420 


S0504140 

S0504150 

S0504160 

S0504170 

S0504180 

S0504190 

S0504200 

S0504210 

S0504220 

S0504230 

S0504240 

S0504250 

S0504260 

S0504270 

S0504280 

S0504290 

S0504300 

S0504310 

S0504320 

S0504330 

S0504340 

S0504350 

S0504360 

S0504370 

S0504380 

S0504390 

S0504400 

S0504410 

S0504420 

S0504430 

S0504440 

S0504450 

S0504460 

S0504470 

S0504480 

S0504490 

S0504500 

S0504510 

S0504520 

S0504530 

S0504540 

S0504550 

S0504560 

S0504570 

S0504580 

S0504590 

S0504600 

S0504610 

S0504620 

S0504630 

S0504640 

S0504650 
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GO TO 280 

S0504660 

310 

CONTINUE 

S0504670 


CALL ANSW (11, INPT , MODEL , IDXLV , lER) 

S0504680 


GO TO 330 

S0504690 

320 

WRITE(ICU,9003) lESCAJ , lESCAJ 

S0504700 


IF (IRUN .EQ. 1) GO TO 200 

S0504710 


GO TO 100 

S0504720 

330 

DO 340 I = 1,12 

S0504730 

340 

MDLNAM(I) = LMODEL(I,MODEL) 

S0504740 


MODEL = MODEL + 3 

S0504750 


M0DEL4 = MODEL .EQ. 4 

S0504760 


MODELS = MODEL .EQ. 5 

S0504770 


M0DEL6 = MODEL .EQ. 6 

S0504780 


IF (BATCH) GOTO 350 

S0504790 


WRITE(ICU,9033) lESA, IESJ,>mLNAM 

S0504800 


GET SYSTEM TIME AND DATE 

S0504810 

350 

CALL FTIME(IFRMT) 

S0504820 


CALL CODE (80) 

S0504830 


READ (IFRMT.9022) INPTl , JTIME, JDAY, JMON, JYEAR 

S0504840 


JTIME = INPTl* 100+ JTIME 

S0504850 

360 

LSDT(l) = IIHBE 

S0504860 


LSDT(2) = IIHST 

S0504870 


CALL CODE 

S0504880 


TOITE (IFRMT,9004) JTIME, (LSDT( I) ,1=1 ,2) , JDAY, JMON, JYEAR 

S0504890 


READ IN THE LAUNCH TIME AND DATE 

S0504900 


CALL OPEN(IDCB,IER,NAMF, 1) 

S0504910 


IF (lER .NE. -6) GO TO 370 

S0504920 


WRITE (ICU,9007) NAME 

S0504930 


GO TO 390 

S0504940 

370 

IF (lER .GE. 0) GO TO 380 

S0504950 


WRITE (ICU,9008) NAME 

S0504960 


GO TO 390 

S0504970 

380 

CALL READF(IDCB,IER,IFRMT) 

S0504980 


CALL CLOSE (IDCB) 

S0504990 

390 

CONTINUE 

S0505000 


CALL CODE(20) 

S0505010 


READ ( IFRMT , 9004 ) LTIME , LSDT ( 1 ) , LSDT ( 2 ) , LDAY , LMON ( 1 ) , LMON ( 2 ) , LYEAR 

S0505020 


IFdPLACE.EQ. 1) LSDT(1)=IIHBP 

S0505030 


IF (BATCH) GOTO 400 

S0505040 


WRITE(ICU,9034) INV, LTIME, (LSDT(I) ,1=1,2) ,LDAY, (LMON(I) ,1=1,2) , 

S0505050 

*LYEAR,OFF,IESB, (IESD,I=1 ,22) 

S0505060 

400 

CALL IFNBR(IFRMT,-1,IER,IIU) 

S0505070 


IF (lER .EQ. 0) GO TO 420 

S0505080 

410 

WRITE (ICU,9002) INV, OFF, 5,0 

S0505090 


IF (BATCH) GO TO 2420 

S0505100 


GO TO 360 

S0505110 

420 

INPT(l) = 0 

S0505120 


INPT(4) = 0 

S0505130 


INPT(7) = 0 

S0505140 


INPT(2) = IBLNK 

S0505150 


INPT(3) = IBLNK 

S0505160 


INPT(5) = IBLNK 

S0505170 
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n o o 


INPT (6) = IBLNK 


S0505180 

CALL CODE(80) 


S0505190 

READ (IFRMT,9004) (INPT(I) , 1=1 , 7) 


S0505200 

IF (IFRMT(l) .EQ. MINUSl) GO TO 430 


S0505210 

IF (IFRMT(l) .EQ. MINUS9) GO TO 20 


S0505220 

IF (INPTl .GE. 0) GO TO 440 


S0505230 

GO TO 410 


S0505240 

430 WRITE(ICU,9003) (lESCAJ ,1=1 , 3) 


S0505250 

GOTO 280 


S0505260 

440 IF(INPTl.GT.O) LTIME = INPTl 


S0505270 

IF ( INPT ( 2 ).EQ. IBLNK. AND. INPT (3). EQ. IBLNK) 

GO TO 450 

S0505280 

LSDT(l) = INPT(2) 


S0505290 

LSDT(2) = INPT(3) 


S0505300 

450 IF (INPT(4) .GT. 0) LDAY = INPT(4) 


30505310 

IF (INPTO) . EQ. IBLNK. AND. INPT (6) . EQ. IBLNK) 

GO TO 460 

S0505320 

LMON(l) = INPT (5) 


S0505330 

LMON(2) = INPT(6) 


S0505340 

460 IF (INPT (7) .GT. 0) LYEAR = INPT (7) 


S0505350 

470 DO 480 1=1,12 


S0505360 


TF(LM0N(1).EQ.M0NTHS(2*I-1).AND.LM0N(2).EQ.M0NTHS(2*D) go to 490 S0505370 


480 CONTINUE S0505380 

URITE(ICU,9035) lESA, (lESD , 1=1 , 1 1) S0505390 

GO TO 400 S0505400 

490 MMON=I S0505410 

IF(BATCH) GOTO 510 S0505420 

WRITE(ICU,9036) IESA,IESA,IESJ,LTIME,LSDT(1) ,LSDT(2) ,LMY,LMON(l) , S0505430 
*LMON(2) ,LYEAR S0505440 

read in the launch VEHICLE . S0505450 

AND FILL THE VPAR ARRAY WITH THE S0505460 

APPROPRIATE VEHICLE PARAMETERS S0505470 

500 WRITE(ICU,9037) INVNDR, INV,OFF,ULINE,OFF,ULINE,OFF,ULINE,OFF, S0505480 

*ULINE,0FF,ULINE,0FF S0505490 

510 DO 520 1=1,10 S0505500 

520 INPT(I) = IBLNK S0505510 

READ(IIU,9001) INPT S0505520 

IF(BATCH .OR. INPTl .NE. MINUSl) GOTO 530 S0505530 

WRITE(ICU,9003) lESCAJ.IESCAJ S0505540 

GOTO 360 S0505550 

530 IF (INPTl .EQ. IBLNK. OR. INPTl .EQ. IIHSH) INPTl = IHS S0505560 

IF huPTl .EQ. IIHTI) INPTl = IHT S0505570 

IF ^MPTl .EQ. MINUS9) GO TO 20 S0505580 

IF (INPTl. EQ. IHS. OR. INPTl. EQ. IHT. OR. INPTl. EQ.IIHD2. OR. INPTl. EQ. S0505590 
*IIHD3) GO TO 630 S0505600 

CALL CODE(20) S0505610 

READ (INPT, 9006) (IFRMT(I) , 1=1 , 10) S0505620 

j = 0 S0505630 

1=0 S0505640 

540 I = I+l S0505650 

IF (I .GT. 10) GO TO 620 S0505660 

IF aFRMT(I) .EQ. IBLNK. AND. J .EQ. 0) GO TO 540 S0505670 

j = j+1 S0505680 

GO TO (550, 560, 570, 580, 590, 600), J S0505690 
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550 

IF (IFRMT(I) .EQ. IHD) GO TO 540 

S0505700 


GO TO 620 

S0505710 

560 

IF (IFRMT(I) .EQ. IHE) GO TO 540 

S0505720 


GO TO 620 

S0505730 

570 

IF (IFRNT(I) .EQ. IHL) GO TO 540 

S0505740 


GO TO 620 

S0505750 

580 

IF (IFRMT(I) .EQ. IHT) GO TO 540 

S0505760 


GO TO 620 

S0505770 

590 

IF (IFRMT(I) .EQ. IHA) GO TO 540 

S0505780 


GO TO 620 

S0505790 

600 

IF (IFRMT(I) .EQ. IH2) GO TO 610 

S0505800 


IF UFRMT(I) .NE. IH3) GO TO 620 

S0505810 


INPTl = I IHD 3 

S0505820 


GO TO 530 

S0505830 

610 

INPTl = IIHD2 

S0505S40 


GO TO 530 

S0505850 

620 

CONTINUE 

S0505860 


WRITE (ICU.9002) INV,0FF,6,0 

S0505870 


IF (BATCH) GO TO 2420 

S0505880 


GO TO 500 

S0505890 

630 

IDXLV=7 

S0505900 


CALL ANSW ( 2 , INPT , IVHICL , IDXLV , lER) 

S0505910 


IF(BATCH) GOTO 640 

S0505920 


WRITE(ICU,9038) lESA.IESJ, (LV(I) , I=IDXLV, IDXLV+6) 

S0505930 

640 

IDX= IDXLV 

S0505940 


DO 650 1=1,7 

S0505950 


TITLE(I)=LV(IDX) 

S0505960 

650 

IDX=IDX+1 

S0505970 


I=IVHICL 

S0505980 


DO 660 J=l,17 

S0505990 

660 

VPAR(J) = VPARS(J.I) 

S0506000 

— 

LAUNCH TYPE (NORMAL , SINGLE ENGINE, CONFLAGRATION) 

S0506010 

670 

IF (BATCH) GOTO 680 

S0506020 


WRITE (ICU, 9039) INVNDR , INV , OFF , ULINE , OFF , ULINE , OFF 

S0506030 

680 

INPTl =■ IBLNK 

S0506040 


READ (IIU, 9001) INPTl 

S0506050 


IF(BATCH .OR. INPTl .NE. MINUSl) GOTO 690 

S0506060 


WRITE (ICU, 9003) lESCAJ, lESCAJ 

S0506070 


GOTO 500 

S0506080 

690 

IF (INPTl .EQ. IBLNK. OR. INPTl .EQ. INOJ) INPTl = INJ 

S0506090 


IF (INPTl .EQ. IIHSI) INPTl = IHS 

S0506100 


IF (INPTl .EQ. IIHCO) INPTl = IHC 

S0506110 


IF (INPTl .EQ. MINUS9) GO TO 20 

S0506120 


IF (INPTl. EQ. INJ. OR. INPTl. EQ. IHS. OR. INPTl. EQ. IHC) GO TO 700 

S0506130 


WRITE (ICU, 9002) INV, OFF, 7,0 

S0506140 


IF (BATCH) GO TO 2420 

S0506150 


CO TO 670 

S0506160 

700 

IDXLT=7 

S0506170 


CALL ANSW ( 3 , INPT , NORMAL , IDXLT , I ER) 

S0506180 


IF (BATCH) GOTO 710 

S0506190 


WRITE(ICU,9040) IESA,IESJ, (LT(I) ,I=IDXLT,IDXLT+6) 

S0506200 

710 

IDX=IDXLT 

S0506210 
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DO 720 1=1,7 
JDX=I+7 

TITLE (JDX)=LT(IDX) 

720 IDX=y)X+l 

C VEHICLE PROPELLANT TEMPEPJITURE 

730 RNPT=0.0 

TPROP=AVTMP (MMON) 

IF(BATCH) GOTO 740 
WRITE(ICU,9041) INV.TPROP ,OFF 
740 CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 750 
WRITE (ICU,9002) INV,OFF,8,0 
IF (BATCH) GO TO 2420 
GO TO 730 
750 CALL C0DE(80) 

READ (IFRNT,*) RNPT 

IF(BATCH .AND, RNPT ,LT. 0.0) RNPT = 0.0' 

IF (RNPT .EQ. MINSl) GO TO 760 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 770 
WRITE (ICU,9002) INV,0FF,8,0 
GO TO 730 

760 WRITE(ICU,9003) lESCAJ.IESCAJ 
GOTO 670 

770 IF(RNPT.GT.O.O) TPROP=RNPT 
IF(BATCH) GOTO 780 
WRITE(ICU,9042) lESA.IESJ.TPROP 
780 TPROPC=TPROP 

TPROP=TPROP+273. 16 
IF(MODEL6) GOTO 1010 

C SPECIES TO COMPUTE CONCENTRATIONS AND DEPOSITIONS FOR 

790 DO 800 1=1,12 

ICHAR(I) = IBLNK 
IF (I .GT. 4) GO TO 800 
IPLLNT(I) = 0 
800 CONTINUE 

IF (BATCH) GO TO 830 
IF (MODEL4) GO TO 810 

WRITE (ICU,9082) INVNDR, INV,OFF,ULINE,OFF 
GO TO 820 

810 WRITE (ICU.9043) INVNDR, INV, OFF, ULINE, OFF, ULINE, OFF, ULINE, OFF, 
*ULINE,OFF 
820 CONTINUE 

830 CALL IFNBR(IFRMT,20,IER,IIU) 

IF (BATCH) GO TO 850 
IF (IFRMT(l) .NE. MINUS 1) GO TO 840 
WRITE (ICU,9003) lESCAJ.IESCAJ 
GO TO 730 

840 IF (IFRMT(l) .EQ. MINUS9) GO TO 20 
850 JJ = 1 
I = 20 

IF (lER .NE. 0) GO TO 860 
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L liillllllll 


IPLLNT(l) = 1 
GO TO 980 

860 DO 870 1=40,60 
870 IFRMT(I) = IBLNK 
CALL CODE (80) 

READ (IFRMT.9006) (IFRMT(I+39) ,1=1 ,20) 

1 = 0 

880 I = I+l 

IF (I ,GT. 20) GO TO 1000 

IF (IFRMT(39+I) .EQ. IBLNK. OR. IFRMT(39+I) .EQ. IHCMA) GO TO 880 

IF UFRMT09+I) .EQ. IHC) GO TO 940 

IF hFRHT09+I) .EQ. IHA) GO TO 910 

IF (IFRMT(39+I) .EQ. IHH) GO TO 890 

WRITE (ICU,9002) INV,OFF,9,0 

IF (BATCH) GO TO 2420 

GO TO 790 

890 IPLLNT(JJ) = 1 

900 IF (IFRMT(40+I).NE.IHC.AND.IFRMT(40+I).NE.IHL) GO TO 980 
I = I+l 
GO TO 900 

910 IPLLNT(JJ) = 4 

920 IF (IFimT(40+I).EQ.IHL.OR.IFRMT(40+I).EQ.IH2) GO TO 930 
IF hFRMT(40+I).NE.IHO.AND.IFRMT(40+I).NE.IH3) GO TO 980 
930 I = I+l 
GO TO 920 

940 IF (IFRMT(40+I) .EQ. IHO) GO TO 970 
IF (IFRMT(40+I) .EQ. IH2) GO TO 960 
950 IPLLNT(JJ) = 3 
GO TO 980 
960 I = I+l 

IPLLNT(JJ) = 2 
GO TO 980 
970 I = I+l 

IF (IFRMT(40+I) .EQ. IH2) GO TO 960 
GO TO 950 
980 JJJ = JJ*3-3 

III = IPLLNT(JJ)*3-3 
DO 990 J=l,3 

990 ICHAR(J+JJJ) = SP(J+III) 

JJ = JJ+1 
GO TO 880 
1000 CONTINUE 

IF (JJ .EQ. l.AND.IPLLNT(JJ) .EQ. 0) GO TO 850 
IF (BATCH) GOTO 1010 

WRITE(ICU,9044) lESA.IESJ, ( (ICHAR(I+12-3*J) ,1=1 ,3) , J=1 ,4) 

C ENTER ENTRAINMENT PARAMETERS 

1010 CONTINUE 

IF(NORMAL.EQ. 1) GO TO 1020 

GAMMAX=GAMMAC 

GAMMAY=GAMMAC 

GAMMAZ=GAMMAC 

GO TO 1030 
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1020 GAI-1MAX=GAMMAI 
GAMMAY=GAMMAI 
GAMMAZ=GA1-IMAI 
1030 CONTINUE 

IF(IRUN.LT.3) GO TO 1280 

1040 WRITE (ICU, 9045) GAMMAX , GAMMAY , GAMMAZ , INVNDR , INV , OFF , ULINE , OFF 
INPTl = IBLNK 
READ(IIU,9001) INPTl 
IF(INPT1 .NE. MINUSl) GOTO 1050 
WRITE(ICU,9003) lESCAJ ,IESCAJ 
IF(MODEL6) GOTO 730 
GOTO 790 

1050 IFdNPTl .EQ. MINUS9) GOTO 20 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.INJ. OR, INPTl. EQ.INOJ) GO TO 1270 
IF (INPTl .EQ. lYSJ. OR. INPTl. EQ.IYESJ) GO TO 1060 
WRITE (ICU,9002) INV, OFF, 9,1 
IF (BATCH) GO TO 2420 
GO TO 1040 

1060 IF (BATCH) GO TO 1080 

WRITE(ICU,9046) lESA, IESJ,GA>1MAX 
1070 WRITE(ICU,9047) IESA,IESJ, INV, GAMMAX, OFF 
1080 RNPT=0,0 

CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 1100 
1090 WRITE (ICU,9002) INV,OFF,9,2 
IF (BATCH) GO TO 2420 
GO TO 1070 
1100 CALL CODE (80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 1110 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 1120 
GO TO 1090 

1110 WRITE(ICU,9003) lESCAJ 
GOTO 1040 

1120 IF (RNPT. GT. 0,0) GAMMAX=RNPT 
1130 IF (BATCH) GO TO 1140 

WRITE(ICU,9048) lESA, I ESJ, INV, GAMMAY, OFF 
1140 RNPT=0.0 

CALL IFNBR (IFRMT, 14, IER,IIU) 

IF (lER .EQ. 0) GO TO 1160 
1150 WRITE (ICU,9002) INV, OFF, 9, 3 
IF (BATCH) GO TO 2420 
GO TO 1130 
1160 CALL CODE (80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 1070 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 1170 
GO TO 1150 

1170 IF(RNPT.GT.O.O) GAMMAY=RNPT 
1180 IF (BATCH) GO TO 1190 
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WRITE(ICU,9049) IESA,IESJ,INV,GAMMAZ,OFF 

S0507780 

1190 

1 RNPT=0.0 

S0507790 


CALL IFNBR(IFRMT,14,IER,IIU) 

S0507800 


IF (lER .EQ, 0) GO TO 1210 

S0507810 

1200 

WRITE (ICU,9002) INV,OFF,9,4 

S0507820 


IF (BATCH) GO TO 2420 

S0507830 


GO TO 1180 

S0507840 

1210 

CALL CODE (80) 

S0507850 


READ (IFRMT,*) RNPT 

S0507860 


IF (RNPT .EQ. MINSl) GO TO 1130 

S0507870 


IF (RNPT .EQ. MINS9) GO TO 20 

S0507880 


IF (RNPT .GE. 0.0) GO TO 1220 

S0507890 


GO TO 1200 

S0507900 

1220 

IF(RNPT.GT.O) GAMMAZ=RNPt 

S0507910 

C 

CHECK PRODUCT OF GAMMA'S 

S0507920 


IF ( NORMAL. GT.l) GO TO 1230 

S0507930 


PR0D=ABS (GAMMAX*GAMMAY*GAMMAZ- . 262 14) 

S0507940 


GO TO 1240 

S0507950 

1230 

PROD=ABS (GAMMAX*GAMMAY- . 25 ) 

S0507960 

1240 

CONTINUE 

S0507970 


IF(BATCH .OR. PROD. LE. . 0001) GO TO 1270 

S0507980 

1250 

WRITE(ICU,9050) INVNDR, INV.OFF.ULINE.OFF 

S0507990 


INPTl = IBLNK 

S0508000 


READ(IIU,9001) INPTl 

S0508010 


IF (INPTl .NE. MINUS 1) GOTO 1260 

S0508020 


l-'RITE(ICU,9003) lESCAJ.IESCAJ 

S0508030 


GOTO 1070 

S0508040 

1260 

IF(INPT1 .EQ. MINUS9) GOTO 20 

S0508050 


IF ( INPT 1 . EQ . IBLNK . OR . INPT 1 . EQ . lYS J . OR. INPT 1 . EQ . lYES J) 

GO TO 1270 S0508060 


IF (INPTl .EQ. INJ. OR. INPTl .EQ. INOJ) GO TO 1070 

S0508070 


WRITE (ICU.9002) INV,OFF,0,0 

S0508080 


GO TO 1250 

S0508090 

1270 

CONTINUE 

S0508100 


WRITE (ICU,9051) lESA.IESJ, GAMMAX , GAMMAY , GAMMAZ 

S0508110 

1280 

CONTINUE 

S0508120 

C 

ENTER LAUNCH COMPLEX NWffiER 

S0508130 

1290 

CONTINUE 

S0508140 


DO 1300 1=1,6 

S0508150 


IFRMT(I*2-1) - ULINE(l) 

S0508160 

1300 

IFRMT(I*2) = ULINE(2) 

S0508170 


GO TO (1310,1320,1330,1330) IVHICL 

S0508180 

1310 

LDX=18 

S0508190 

. 

MDX=IHS 

S0508200 


NDX(l) = LC(1) 

S0508210 


NDX(2) = IHA 

S0508220 


IFRMT(l) = INVNDR(l) 

S0508230 


IFRMT(2) = INVNDR(2) 

S0508240 


GO TO 1340 

S0508250 

1320 

LDX=30 

S0508260 


MDX=IHT 

S0508270 


NDX(l) = LC(7) 

S0508280 


NDX(2)=IBLNK 

S0508290 
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1330 


1340 


IFRMK7) = INVMDR(l) 

IFRiMT(8) = IKVNDR(2) 

GO TO 1340 

LDX=24 

MDX=IHD 

NDX(l) = LC(ll) 
NDX(2)=IBLNK 
IFRKT(ll) = INVNDR(l) 
IFRiMT(12) = INVNDR(2) 
CONTINUE 
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1350 


1360 


1370 


1380 


1390 


1400 


1410 


1420 


IF (.NOT. BATCH) WRITE(ICU, 9052) (IFRMT(I*2-1) ,IFRMT(I*2) .OFF, 1=1 , 6) S0508400 
INPT(l) = IBLNK S0508410 
INPT(2) = IBLNK S0508420 
READ (IIU, 9001) INPT S0508430 
IF(BATCH .OR. INPTl .NE. MINUSl) GOTO 1350 SO50844O 
WRITE (ICU, 9003) lESCAJ, lESCAJ S0508450 
IF (IRUN .LT. 3) GO TO 790 S0508460 
GO TO 1040 S0508470 
IF (INPTl .EQ. MINUS9) GO TO 20 S0508480 
IFdNPTl.NE. IBLNK) GO TO 1360 S0508490 
INPT(l) = NDX(l) S0508500 
INPT(2) = NDX(2) S0508510 
LSITE =1 S0508520 
CALL ANSW(5, INPT, IDX, LSITE, lER) • S0508530 
IF (lER .EQ. 0) GO TO 1380 S0508540 
IF (BATCH) GO TO 2420 S0508550 
WRITE (ICU, 9002) INV, OFF, 10,0 S0508560 
go’ to 1290 S0508570 
IF (LSITE .GT. 1) LSITE = LSITE+2 S0508580 
IF (LSITE .GT. 1) GO TO 1390 S0508590 
X = 0 S0508600 
IF (INPT(2) .EQ. IHA.OR.INPT(2) .EQ. IBLNK) 1=1 S0508610 
IF (INPT(2) .EQ. IHB) 1=2 S0508620 
IF dNPT(2) .EQ. IHC) 1 = 3 S0508630 
IF (I .EQ. 0) GO TO 1370 S0508640 
LSITE = I S0508650 
CONTINUE S0508660 
IF (BATCH) GO TO 1430 S0508670 
IF (lER .EQ. O.AND.MDX .EQ. IDX) GO TO 1420 S0508680 
WRITE(ICU,9053) IESA,IESJ,INPT(1) ,INPT(2) ,INVNDR,INV,OFF,ULINE,OFFS0508690 
INPTl = IBLNK ' S0508700 
READ(IIU,9001) INPTl S0508710 
IF(INPTl.NE.MINUSl) GOTO 1410 S0508720 
WRITE(ICU,9003) lESCAJ S0508730 
GOTO 1290 S0508740 
IF(INPT1.EQ.MINUS9) GOTO 20 S0508750 
IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 1420 S0508760 
IF (INPTl .EQ. INJ. OR. INPTl .EQ. INOJ) GO TO 1290 ' S0508770 
WRITE (ICU, 9002) INV, OFF, 0,0 S0508780 
GO TO 1400 S0508790 
CONTINUE S0508800 
WRITE(ICU,9054) IESA,IESJ,LC(LSITE*2-1) ,LC(LSITE*2) S0508810 
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1430 


1440 

1450 

1460 


1470 

1480 

1490 

1500 


IF{.N0T.M0DEL4) GOTO 1610 S0508820 

ENTER CALCULATION LOCATION (SURFACE, STABILIZATION, USER INPUTS0508830 

IF(. NOT. BATCH) GOTO 1440 S0508840 
INPT(l) = IBLNK S0508850 
INPT(2) = IBLNK S0508860 
INPT{3) = IBLNK S0508870 
INPT(4) = IBLNK S0508880 
INPT(5) = IBLNK S0508890 
READ (IIU, 9001) INPT S0508900 
IFdNPTl.EQ.IHS .OR. INPTl . EQ. IIHST .OR. INPTl . EQ. IBLNK) GOTO 1460S0508910 
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CALHT =0.0 
CALL C0DE(20) 

READ (INPT,*) CALHT 
ICALC = 3 

CALHT = AMAX 1(0.0, CALHT) 

IFdAGAIN .EQ. 1) GOTO 2400 
GOTO 1620 

WRITE (ICU , 9 05 5 ) INVNDR , INV , OFF , ULINE , OFF , ULINE , OFF 
INPTl = IBLNK 
READ(IIU,9001) INPTl 
IF(INPT1 .NE. MINUSl) GOTO 1460 
WRITE(ICU,9003) lESCAJ , lESCAJ 
GOTO 1290 
IDXCL=7 
IF (INPTl 
IF (INPTl 
IF (INPTl 


1510 

1520 


.EQ. MINUS9) GO TO 20 

.EQ. IBLNK. OR. INPTl .EQ. IIHSU) INPTl = IHS 
.EQ. IIHAN) INPTl = IHA 
CALL ANSW(6 , INPT , ICALC , IDXCL , lER) 

IF (lER .EQ. 0) GO TO 1470 
WRITE (ICU, 9002) INV, OFF, 11,0 
GO TO 1440 

IF (ICALC .NE. 2) GO TO 1520 
DO 1480 1=1,4 

IF (IPLLNT(I) .EQ. 4) GO TO 1490 
CONTINUE 
GO TO 1520 
WRITE (ICU, 9023) 

DO YOU WISH TO ENTER A DIFFERENT CALCULATION HEIGHT? 

WRITE (ICU, 9024) INVNDR, INV, OFF, ULINE, OFF 
INPTl = IBLNK 
READ (IIU, 9001) INPTl 
IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 1430 S0509230 

IF (INPTl. EQ. INJ. OR. INPTl. EQ. INOJ) GO TO 1510 S0509240 

IF (INPTl .EQ. MINUSl) GO TO 1450 S0509250 

IF (INPTl .EQ. MINUS9) GO TO 20 S0509260 

WRITE (ICU, 9002) INV, OFF, 24,0 S0509270 

IF (BATCH) GO TO 2420 S0509280 

GO TO 1500 S0509290 

CONTINUE S0509300 

CONTINUE S0509310 

IF(ICALC.EQ.3) GO TO 1530 S0509320 

IF( . NOT. BATCH) WRITE (ICU, 9056) lESA, lESJ , (CL(I) , I=IDXCL, IDXCL+6) S0509330 
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1530 

1540 

1550 


1560 

1570 

1580 

1590 

1600 


1610 

1620 


1630 


1640 


GO TO 1620 

ENTER CALCULATION HEIGHT CALHT 

WRITE ( ICU , 905 7 ) lESA, lES J , INV , CALHT , OFF 
RNPT= CALHT 

CALL IFNBRdFRMT, 14,IER,IIU) 

IF (lER .EQ. 0) GO TO 1550 
WHITE (ICU, 9002) INV, OFF, 11,1 
GO TO 1530 
CALL CODE (80) 

READ (IFRiMT,*) RNPT 
IF (RNPT ,EQ. MINSl) GO TO 1560 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 1570 
GO TO 1540 

IFdAGAIN .EQ. 1) GOTO 2410 
WRITE(ICU,9003) lESCAJ 
GOTO 1430 
CALHT=RNPT 

URITE(ICU,9058) lESA.IESJ, CALHT 
DO 1580 1=1,4 

IF (IPLLNT(I) .EQ. 4) GO TO 1590 

CONTINUE 

GO TO 1610 

IF (CALHT .LE. 5.0) GO TO 1610 
WRITE (ICU, 9023) 

DO YOU WISH TO ENTER A DIFFERENT CALCULATION HEIGHT? 

WRITE (ICU, 9024) INVNDR , INV , OFF , ULINE , OFF 

INPTl = IBLNK 

READ (IIU,9001) INPTl 

IF (INPTl . EQ. IBLNK. OR. INPTl . EQ. lYSJ.OR. INPTl . EQ. lYESJ) 

IF dNPTl.EQ.INJ. OR. INPTl. EQ.INOJ) GO TO 1610 

IF dNPTl .EQ. MINUSl) GO TO 1450 

IF dNPTl .EQ. MINUS9) GO TO 20 

WRITE (ICU, 9002) INV, OFF, 24,0 

IF (BATCH) GO TO 2420 

GO TO 1600 

IFdAGAIN. EQ. 1) GO TO 2400 
CONTINUE 

ENTER CLOUD SHAPE 

NNNTRY = 1 
IF (BATCH) GOTO 1630 

WRITE (I CU , 905 9 ) INVNDR , INV , OFF , ULINE , OFF 

INPTl = IBLNK 

READ (IIU, 9001) INPTl 

IF(BATCH .OR. INPTl.NE. MINUSl) GOTO 1640 
WRITE(ICU,9003) IESCAJ,IESCAJ 
IF (MODEL .NE. 4) GO TO 1290 
GOTO 1430 

IF (INPTl .EQ. MINUS9) GO TO 20 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IIHEL) INPTl = HIE 

IF (INPTl .EQ. IIHSP) INPTl = IHS 

IDXCS=5 
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CALL ANSW ( 7 , INPT , ISHAPE , IDXCS , lEPv) 

IF(. NOT. BATCH .OR. ISHAPE .GT. 0) GOTO 1650 
ISHAPE = 1 
IDXCS = 5 
1650 CONTINUE 

IF (lER .EQ. 0) GO TO 1660 
WRITE (ICU.9002) INV, OFF, 12,0 
IF (BATCH) GO TO 2420 
GO TO 1620 

1660 IF (BATCH) GO TO 1670 

WRITE(ICU,9060) IESA,IESJ, (CS (I) , I=IDXCS , IDXCS+4) 

C DETERMINE IF GRAVITATIONAL SETTLING OCCURS. 

1670 GASSET = .FALSE. 

GRVSET = .FALSE. 

IF(HODEL5) GOTO 1690 
GRVSET = .TRUE. 

IF(MODEL6) GOTO 1690 
DO 1680 I = 1,4 
IF(IPLLNTd) .EQ. 4) GOTO 1690 
GASSET = .TRUE. 

1680 CONTINUE 

GRVSET = .FALSE. 

C CHECK FOR PRODUCTION OR OPERATIONAL MODE. 

1690 IF (IRUN .LT. 3) GO TO 2390 

C ENTER ABSORPTION COEFFICIENT 

IF (MODEL5) GOTO 1810 

IF(.NOT. MODEL4 .OR. .NOT. GASSET) GOTO 1750 
1700 lsTlITE(ICU,9061) INV, OFF 
RNPT = GAMMAP(21) 

CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 1720 
1710 TOITE (ICU,9002) INV, OFF, 12,1 
IF (BATCH) GO TO 2420 
GO TO 1700 
1720 CALL CODE (80) 

READ (IFRMT,*) RNPT 

IF (RNPT .EQ. MINSl) GO TO 1730 

IF (RNPT .EQ. MINS9) GO TO 20 

IF (RNPT .GE. 0.0. AND. RNPT .LE. 1.0) GO TO 1740 

GO TO 1710 

1730 WRITE(ICU,9003) lESCAJ, lESCAJ 
GOTO 1620 

1740 IF(RNPT. GE. 0.0. AND. RNPT. LE. 1.0) GAMMAP(21)=RNPT 
WRITE (ICU, 9062) lESA, IESJ,GAMMAP(21) 

C ENTER DECAY COEFFICIENT 

1750 IF(.NOT.MODEL4) GOTO 1810 
1760 WRITE(ICU,9063) INV, OFF 
RNPT=0.0 

CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) CO TO 1780 
1770 WRITE (ICU, 9002) INV, OFF, 12,2 
IF (BATCH) GO TO 2420 
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GO TO 1760 
1780 CALL CODE (80) 

READ (IFRllT,*) RNPT 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .EQ. MINSl) GO TO 1790 
IF (RNPT .GE. 0.0) GO TO 1800 
GO TO 1770 

1790 WRITE (ICU, 9003) lESCAJ , lESCAJ 
IF(GRVSET) GOTO 1620 
GOTO 1700 

1800 IF(RNPT.GT.O.O) DECAY=RNPT 

WRITE(ICU,9064) lESA, lESJ, DECAY 

C ENTER ALPHA AND BETA 

1810 WRITE(ICU,9065) ALPHA, BETA, INVNDR.INV, OFF, ULINE, OFF 
INPTl = IBLNK 
READ(IIU,9001) INPTl 
IFdNPTl .NE. MINUSl) GOTO 1820 
WRITE (ICU, 9003) lESCAJ, lESCAJ 
IF(MODEL5) GOTO 1620 
IF(.NOT.MODEL4) GOTO 1700 
GOTO 1760 

1820 IFdNPTl .EQ. MINUS9) GOTO 20 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.INJ. OR. INPTl. EQ.INOJ) GO TO 1920 
IF (INPTl .EQ. lYSJ. OR. INPTl .EQ. lYESJ) GO TO 1830 
WRITE (ICU, 9002) INV, OFF, 12,3 
GO TO 1810 

1830 WRITE(ICU,9066) IESA,IESJ 
RNPT=0.0 

CALL IFMBR(IFRMT, 14,IER,IIU) 

IF (lER .EQ. 0) GO TO 1850 
1840 WRITE (ICU, 9002) INV, OFF, 12,4 
IF (BATCH) GO TO 2420 
GO TO 1830 
1850 CALL CODE (80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 1860 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 1870 
GO TO 1840 

1860 WRITE (ICU, 9003) lESCAJ 
GOTO 1810 

1870 IF(RNPT.GT.O.O) ALPHA=RNPT 
1880 WRITE (ICU, 906 7) IESA,IESJ 
RNPT=0 . 0 

CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 1900 
1890 WRITE (ICU, 9002) INV, OFF, 12, 5 
IF (BATCH) GO TO 2420 
GO TO 1880 
1900 CALL CODE (80) 

READ (IFRMT,*) RNPT 

IF (RNPT .EQ. MINSl) GO TO 1830 
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IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 1910 
GO TO 1890 

1910 IF(RNPT.GT.O.O) BETA=RNPT 

1920 WRITE (ICU, 9068) lESA.IESJ, ALPHA, BETA 

C ENTER DOWNVJIND EXPANSION DISTANCES XRY.XRZ 

1930 WRITE(ICU,9069) XRY,XRZ,INVNDR,INV,OFF,ULINE,OFF 
INPTl = IBLNK 
READ(IIU,9001) INPTl 
IFdNPTl .NE. MINUSl) GOTO 1940 
WRITE(ICU,9003) lESCAJ, lESCAJ 
GOTO 1810 

1940 IFdNPTl .EQ. MINUS9) GOTO 20 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.INJ. OR. INPTl. EQ.INOJ) GO TO 2040 
IF dNPTl .EQ. lYSJ. OR. INPTl. EQ.IYESJ) GO TO 1950 
WRITE (ICU, 9002) INV, OFF, 12,6 
IF (BATCH) GO TO 2420 
GO TO 1930 

1950 WRITE(ICU,9070) lESA.IESJ 
RNPT=0 . 0 

CALL IFKBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 1970 
1960 WRITE (ICU, 9002) INV, OFF, 12,7 
IF (BATCH) GO TO 2420 
GO TO 1950 
1970 CALL CODE (80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 1980 
IF (RNPT .EQ. MINS 9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 1990 
GO TO 1960 

1980 WRITE(ICU,9003) lESCAJ 
GOTO 1930 

1990 IF(RNPT.GT.O.O) XRY=RNPT 
2000 WRITE(ICU,9071) lESA.IESJ 
RNPT=0.0 

CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 2020 
2010 WRITE (ICU, 9002) INV, OFF, 12,8 
IF (BATCH) GO TO 2420 
GO TO 2000 
2020 CALL CODE'(80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 1950 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 2030 
GO TO 2010 

2030 IF (RNPT. GT. 0.0) XRZ=RNPT 
2040 WRITE(ICU,9072) lES A, lESJ, XRY.XRZ 
IF(.NOT.MODEL4) GOTO 2140 
C ENTER TIMAV 

2050 WRITE(ICU,9074) INV, TIMAV, OFF, INVNDR, INV, OFF, ULINE, OFF 
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I 


I 


INPTl = IBLNK 
READ ( I lU, 9001) INPTl 
IFdNPTl .NE. MINUSl) GOTO 2070 
2060 WRITE(ICU,9003) lESCAJ.IESCAJ 
GOTO 1930 

2070 IFdNPTl .EO. MINUS9) GOTO 20 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.INJ. OR. INPTl. EQ.INOJ) GO TO 2130 
IF (INPTl .EQ. lYSJ. OR. INPTl .EQ. lYESJ) GO TO 2080 
WRITE (ICU,9002) INV, OFF, 12,9 
IF (BATCH) GO TO 2420 
GO TO 2050 

2080 WRITE(ICU,9075) lESA.IESJ 
RNPT=0.0 

CALL IFNBR(IFRMT, 14,IER,IIU) 

IF (lER .EQ. 0) GO TO 2100 
2090 WRITE (ICU,9002) INV, OFF, 12 , 10 
IF (BATCH) GO TO 2420 
GO TO 2080 
2100 CALL CODE(80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 2110 
IF (RNPT .EQ. MINS9) GO TO 20 
IF (RNPT .GE. 0.0) GO TO 2120 
GO TO 2090 

2110 WRITE(ICU,9003) lESCAJ 
GOTO 2050 

2120 IF(RNPT.GT.O.O) TIMAV=RNPT 
2130 WRITE(ICU,9076) IESA,IESJ,TIMAV 
2140 IF(.NOT.GRVSET) GOTO 2390 

C ENTER GRAVITATIONAL SETTLING DATA. 

DO 2150 I = l.NVSDEF 
VS(I) = VSDEF(I) 

GAMMAP(I) = GAMDEF(I) 

FS(I) = FSDEF(I) 

2150 DBAR(I) = DBRDEF(I) 

NVS = NVSDEF 
2160 WRITE(ICU,9009) 

WRITE (ICU, 9077) NVS,VS(1) 

IF(NVS .GT. 1) WRITE(ICU,9010) (VS(I) ,I=2,NVS) 

WRITE (ICU, 9081) GAMMAP(l) 

IF(NVS .GT. 1) WRITE(ICU,9010) (GAMMAP(I) ,I=2,NVS) 
WRITE(ICU,9018) FS(1) 

IF(NVS .GT. 1) WRITE(ICU,9010) (FS(I) ,I=2,NVS) 

N = 3 

‘ IF(.N0T.M0DEL6) GOTO 2170 
N = 4 

WRITE(ICU,9015) DBAR(l) 

IF(NVS .GT. 1) WRITE(ICU,9010) (DBAR(I) ,I=2,NVS) 

2170 WRITE (ICU, 9078) INVNDR, INV,OFF,ULINE,OFF 
INPTl = IBLNK 
READ (ICU, 9001) INPTl 
IF(INPT1 .EQ. MINUS9) GOTO 20 
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NLINES = N + 2 

IF(NVS .GT, 1) NLINES = NLINES + N 
IF(NVS ,GT. 11) NLINES = NLINES + N 
IF(INPT1 .NE. MINUSl) GOTO 2180 
WRITE (ICU.9003) (IESCAJ,I=-1 .NLINES) 

IF(.NOT.MODEL4) GOTO 1930 
GOTO 2050 

2180 IF (INPTl.EO.IBLNK.OR.INPTl.EQ.INJ.OR.INPTl.EQ.INOJ) GO TO 2380 
IF (INPTl.EQ.IYSJ.OR.INPTl.EQ.IYESJ) GO TO 2190 
WRITE (ICU,9002) INV.OFF, 12 , 1 1 
IF (BATCH) GO TO 2420 
GO TO 2170 
2190 CONTINUE 

C ENTER THE NUMBER OF SETTLING CATEGORIES 
WRITE(ICU,9079) lESA, lESJ.MAXNVS 
CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. Oy GO TO 2210 
2200 WRITE (ICU.9002) INV.OFF, 12 , 12 
IF (BATCH) GO TO 2420 
GO TO 2190 
2210 CALL CODE (80) 

READ (IFRMT,*) INPTl 

IF (INPTl .EQ. MINSl) GO TO 2220 

IF (INPTl .EQ. MINS9) GO TO 20 

IF (INPTl .GE. 0. AND. INPTl .LE. MAXNVS) GO TO 2230 
GO TO 2200 

2220 NLINES = NLINES + 1 
GOTO 2370 

2230 IF (INPTl .GT. 0) NVS = INPTl 
NVS = MAXOd.MINO (NVS, MAXNVS)) 

WRITE(ICU,9080) lESA, lESJ.NVS 
RNPT = VS(1) 

READdIU,*) (VS(I) ,I=1,NVS) 

NLINES = NLINES + 2 
IF(IFIX(VS(1))+1) 20,2240,2250 
2240 VS(1) = RNPT 
GO TO 2370 

2250 WRITE(ICU,9017) NVS 
RNPT = GAMMAP(l) 

READ(IIU,*) (GAMMAP(I) ,I=1,NVS) 

NLINES = NLINES +2 
IF(IFIX(GAMMAP(1))+1) 20,2260,2270 
2260 GAMMAP(l) = RNPT 
GO TO 2370 

2270 WRITE (ICU, 90 19) NVS 
RNPT = FS(1) 

READ(IIU,*) (FS(I) ,I=1,NVS) 

NLINES = NLINES + 2 
IF(IFIX(FS(1))+1) 20,2280,2290 
2280 FSd) = RNPT 
GO TO 2370 

2290 IF(.NOT.MODEL6) GOTO 2310 
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S0512300 
S0512310 
S0512320 
S0512330 
S0512340 
S05 12350 
S0512360 
S0512370 
S0512380 
S0512390 
S0512400 
S0512410 
S0512420 
S05 12430 
S0512440 
S0512450 


46 



V/RITE(ICU,9ni6) NVS 
RNPT = DBAR(l) 

READdIU,*) (DBAR(I),I=1,NVS) 

NLINES = NLINES + 2 
IF(IFIX(DBAR(1))+1) 20,2300,2310 
2300 DBAR(l) = RNPT 
GO TO 2370 
2310 A1 = 0.0 

DO 2320 I = 1,NVS 
2320 A1 = A1 + FS(I) 

IF(ABS(A1-1.0) .LT. 0.01) GOTO 2370 
DO 2330 1=1, NVS 

IF (ABS(VS(I)-VSDEF(I)) .GT. 0.001) GO TO 2340 

IF (ABS(FS(I)-FSDEFd)) .GT. 0.001) GO TO 2340 

2330 CONTINUE 
GO TO 2370 
2340 A1 = 1.0/Al 

WRITE(ICU,9020) A1 

INPTl = IBLNK 

READ (ICU, 9001) INPTl 

IF (INPTl .EQ. MINUS9) GO TO 20 

IF (INPTl .EQ. MINUSl) GO TO 2370 

NLINES = NLINES + 3 

IF (INPTl .EQ. IBLNK) GO TO 2370 

IF dNPTl .EQ. IHN) GO TO 2350 

WRITE (ICU, 9002) INV,OFF,O,0 

GO TO 2310 

2350 DO 2360 I = 1,NVS 
2360 FS(I) = FS(I)*A1 
C 

.2370 tJRITE (ICU, 9003) (lESCAJ, 1=1 , NLINES) 

GOTO 2160 

2380 WRITE (ICU, 9003) lESCAJ 
C 

2390 CONTINUE 
GO TO 2430 
2400 NNNTRY » 5 
GO TO 2430 
2410 NNNTRY = 6 
GO TO 2430 
2420 NNNTRY = 7 
2430 NNNEST = 6 
CALL REEDM 
END 


S0512460 

S0512470 

S0512480 

S0512490 

S0512500 

S0512510 

S0512520 

S0512530 

S0512540 

S0512550 
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S0512570 

S0512580 

S0512590 

S0512600 

S0512610 

S0512620 

S0512630 

S0512640 

S0512650 
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S0512670 

S0512680 

S0512690 

S0512700 
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S0512720 

S0512730 

S0512740 

S0512750 

S0512760 

S0512770 

S0512780 

S0512790 

S0512800 

S0512810 

S0512820 
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SUBROUTINE ANSW ( IDX , I ALF , JDX , KDX , lER) 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 

INTEGER V ARRAY ( 4 , 1 1 ), INTNMB ( 4 , 1 1 ) 

DATA VARRAY/lHO, IHR, IHP, HID, 

. IHS, 1HT,2HD2,2HD3, 

. 1HN,1HS,1HC,2HXX, 

. 1HH,1H0,1HC,1HA, 

2H39,2H40,2H41,2H17, 

1HS,2HST,1HA,2HXX, 

1HE,1HS.2HXX,2HXX, 

1HU,1HL,2HXX,2HXX, 

1HN,1HY,2HXX,2HXX, 

1HN,1HY,2HXX,2HXX, 

1HC,1HW,1HG,2H-1/ 

DATA INTNMB/2,3,1,4, 

1 , 2 , 3 , 4 , 

1.2, 3,0, 

1 , 2 , 3 , 4 , 

1HS,1HT,1HT,1HD, 

1.2. 3.0, 

2 . 1 . 0 . 0 , 

1 , 2 , 0 , 0 , 

2 , 1 , 0 , 0 , 

1 , 2 , 0 , 0 , 

1,2, 3,0/ 

DATA MINUS9/2H-9/ 
lER = 0 
DO 10 1=1,4 

IF(IALF.EQ.VARRAY(I,IDX)) GO TO 40 
10 CONTINUE 

IF(IALF.EQ.MINUS9) GO TO 20 
lER = 1 
GO TO 30 
20 JDX=-1 
GO TO 50 
30 1=1 

40 JDX= INTNMB (I, IDX) 

KDX=KDX*I-KDX+1 
50 RETURN 
END 


S0600000 

S0600010 

S0600020 

S0600030 

S0600Ci0 

S0600050 

S060C060 

S0600070 

S0600080 

S0600090 

S0600100 

S0600110 

S0600120 

S0600130 

S0600140 

S0600150 

S0600160 

S0600170 

S0600180 

S0600190 

S0600200 

S0600210 

S0600220 

S0600230 

S0600240 

S0600250 

S0600260 

S0600270 

S0600280 

S0600290 

S0600300 

S0600310 

S0600320 

S0600330 

S0600340 

S0600350 

S0600360 

S0600370 

S0600380 

S0600390 
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^ CJ 


REEDM SOURCE MODULE &REDAM 


FTN4 S0700000 

PROGRAM REDAI'ICS) S0700010 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S0700020 

C: ■ S0700030 
C: : S0700040 

C:;: ::: S0700050 

C::: ::: S0700060 

C;:: ORGANIZATION: H. E. CRAMER CO. , INC. ::: S0700070 

C::: ::: S0700080 

C::: WORK FOR: DR. J. B. STEPHENS (ES84) ::: S0700090 

C::: ::: S0700100 

C: : : PROGRAM CODE: REEDM ::: S0700110 

C:;: ::: S0700120 

C::: PROGRAM DESCRIPTION: INPUT USER DATA FOR ROCKET EXHAUST ::: S0700130 

C::: EFFLUENT DIFFUSION ANALYSIS ::: S0700140 

C::: (MULTI-LAYER) ::: S0700150 

C::: ::: S0700160 

C::: INPUT: USER SPECIFIED OPTIONS ::: S0700170 

C::: ::: S0700180 

C::: OUTPUT: PRINTED AND DISPLAYED LISTING OF USER INPUT VALUES ::: S0700190 

C::: ::: S0700200 

C: : S0700210 

C: : S0700220 

C S0700230 

CC S0700240 

C**** BEGIN COMMON AREA ****50700250 

04/02/82 S0700260 

MATH PARAMETERS AND CONSTANTS S0700270 

COMMON /MATH/ PI ,G,CP,MAXLEV,GAIRfAI,GAMMAC S0700280 

C INPUT OPTIONS S0700290 

REAL LAMBDA S0700300 

INTEGER FILE, GOOD, TITLE S0700310 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S0700320 

ISHAPE,GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S0700330 

. XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S0700340 

IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,BOTLAY, S0700350 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) S0700360 

,RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S0700370 

. ,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , S0700380 

TISO(10),TITLE(14),SIGPP(29),SIGLL(29),VS(2O), S0700390 

FS(20) ,MDLNAM(12),DBAR(20) S0700400 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S0700410 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S0700420 

. MODEL4, MODELS, MODEL6 S0700430 

INTEGER RUNNUM,RT,CL,CS S0700440 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S0700450 

. DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,STGXNK,STGYNK, S0700460 

. S ICZ, ISNDFO, CRT, LAYTOP (3 ) ,ITDU, KEEP S0700470 

.MIXING, MAXDEP, LAYBOT(3) S0700480 

. , ALTSV, BATCH, CL(14) ,CS(10) .GASSET, lAGAIN, S0700490 
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ICHAR(12) ,IDXCL,IDXCS,IERROR(5),IFRMT(80), S0700500 

MINUS1,MINUS9,MIMS1,MINS9, S0700510 

M0DEL4, MODELS, M0DEL6.NNMEST,NNNTRY,LLNEST,LLNTRY, S0700520 
RT(24) ,TPROPC,IDXRT S0700530 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NLTIBERS. S0700540 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S0700550 

. TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S0700560 

. CLRLNE.INSLNE, DELINE S0700570 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S0700580 

INVNDR(2) ,ULINE(2) , S0700590 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , S0700600 
CLRLNE.INSLNE, DELINE, S0700610 

lESCAJO) ,NULL,IBLNK, S0700620 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,IN0J,NAMEP(3) S0700630 

C VEHICLE PARAMETERS S0700640 

COMMON /VCLPR/ VPAR(17) S0700650 

C time PARAMETERS S0700660 

COMMON /TIME/ JTIME, JDAY, JYEAR, ISTIME.ISDAY, ISYEAR,LTIME, S0700670 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S0700680 

C SOUND ING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S0700690 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S0700700 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S0700710 

C LAYER PARAMETERS S0700720 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S0700730 

SIGYO(29) S0700740 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S0700750 

COMMON /BLAYR/ DIRB(6) , SPEEDB (6) ,TEMPB (6) S0700760 

C CALCULATED NEW LAYER PARAMETERS S0700770 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) , S0700780 
SPEEDN(32) S0700790 

C CONVERSION FACTORS S0700800 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S0700810 

C S0700820 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S0700830 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S0700840 

C READ/WRITE BUFFER S0700850 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S0700860 

Q*********************************************************************** SO 7 008 70 


C 

C- 


EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(1)),(I0U,IPAR(2)),(IPU1.IPAR(3)) 
, (IPU2,IPAR(4)),(IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP,GRVSET) , (IFRMT(l) ,IFRMT1) 
(INPT(l) ,PLUS(73)) 


END OF COMMON AREA 


EQUIVALENCE 
C 

C**A* 

cc 

CF INPUT FORMAT STATEMENTS 

9001 FORMAT (40A2) 

9002 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2,6H REC. 
*,I2,1H, ,11/) 

9003 FORMAT (2A2,A1) 


S0700880 
S0700890 
S0700900 
S0700910 
S0700920 
S0700930 
S0700940 
****S0700950 
S0700960 
S0700970 
S0700980 
S0700990 
S0701000 
S0701010 
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CF OUTPUT FORMAT STATEMENTS S0701020 

9004 F0RMAT(1H1/1X,38(2H**)/1X,8(2H**) ,44X,8(2K**) /1X,8(2H**) , S0701030 

25H NASA/MSFC MULTIPLE LAYER S0701040 

19H TECHNIQUE - REEDM , 8 (2H**) /1X,8 (2H**) , 8H UPDATE, 15, S0701050 

•13H LOCATION ,2A2, 14X,8(2H**)/IX,8(2H**) , S0701060 

•44X,8(2H**)/1X,38C2H**)///) S0701C70 

9005 F0RIfAT(21X, 14A2 , 7H LAUNCH/) S0701080 

9006 F0RMAT(17X, I7H LAUNCH TIME: ,I7,2A2,7H DATE: , 12 , IX, 2A2 , 14) S0701090 

9007 FORMAT (17X,20H TIME OF EXECUTION: ,I4,2A2,7H DATE: , 12 , IX, 2A2 , 14) S0701100 

9008 F0R1-!AT(/1X,9(2H**) ,13X,15H MODEL OPTIONS , 12X,9(2H**) /) S0701110 

9009 F0RMAT(1X,6H MODEL, 46X, 12A2) S0701120 

9010 F0RMAT(1X,9H RUN TYPE,55X,6A2) S0701130 

9011 F0RMAT(1X,15H LAUNCH VEHICLE, 47X,7A2) S0701140 

9012 F0RMAT(1X,12H LAUNCH TYPE,50X,7A2) S0701150 

9013 F0RMAT(1X,22H LAUNCH COMPLEX NUMBER, 51X.2A2) S0701160 

9014 F0RMAT(1X,8H SPECIES, 44X, 12A2) S0701170 

9015 F0RMAT(1X,12H CLOUD SHAPE, 54X,5A2) S0701180 

9016 F0RMAT(1X,19H CALCULATION HEIGHT, 43X,7A2) S0701190 

9017 F0RMAT(1X,28H CALCULATION HEIGHT (METERS) ,40X,F8. 2) S0701200 

9018 F0RMAT(1X,32H PROPELLANT TEMPERATURE (DEG. C),38X,F6.2) S0701210 

9019 F0RMAT(/1X,9(2H**),11X,19H MODEL PARAMETERS , 10X,9 (2H**) /) S0701220 

9020 F0RMAT(1X,36H CONCENTRATION AVERAGING TIME (SEC. ) ,34X,F6. 2) S0701230 

9021 F0RMAT(1X,18H DECAY COEFFICIENT, 50X,F8. 4) S0701240 

9022 FORMAT(54H ABSORPTION COEFFICIENT (RNG: 0 TO 1,N0 ABSORPTION=0) , S0701250 

15X,F8.4) S0701260 

9023 F0RMAT(1X,23H DIFFUSION COEFFICIENTS, 34X, 1 IHLATERAL ,F8.4/ S0701270 

58X,11HVERTICAL ,F8.4) S0701280 

9024 FORMAT(32H VEHICLE ENTRAINMENT PARAMETERS, 26X, 1 IHALONGWIND .F8.4S0701290 

/58X,11HCR0SSWIND .F8.4/58X, IIHVERTICAL ,F8.4) S0701300 

9025 F0RMAT(1X,37H DOWNWIND EXPANSION DISTANCE (METERS), 20X S0701310 

IIHLATERAL ,F8 . 2/58X, 1 IHVERTICAL ,F8.2) S0701320 

9026 F0RMAT(1H1/1H1) S0701330 

9027 FORMAT(33H RAINFALL RATE (INCHES PER HOUR) ,39X,F5. 2) S0701340 

RAINFALL SCAVENGING COEFFICIENT, 32X,1PE12. 5) S0701350 

TIME RAIN STARTS AFTER LAUNCH (SECONDS) , 30X,F6. 2) S0701360 

RAIN DURATION (HOURS) ,48X,F6. 2) S0701370 

WASHOUT DEPOSITION IS,40X, 14HTIME-DEPENDENT) S0701380 

WASHOUT DEPOSITION IS, 38X, 16HMAXIMUM POSSIBLE) S0701390 

9033 FORMAT(7X,29HNUMBER OF SETTLING CATEGORIES, 38X, 13/ S0701400 

17X,49HTERMINAL FALL VELOCITY VALUES (METERS PER SECOND) , 16X,F5. 4) S0701410 

9034 FORMAT(7X,54HREFLECTION COEFFICIENT VALUES (RNG: 0 TO 1, NO REF.=0S0701420 

1),11X,F5.4) S0701430 

9035 FORMAT (7X,30HFREQUENCY OF OCCURRENCE VALUES, 35X.F5. 4) S0701440 

9036 F0RMAT(40H GRAVITATIONAL SETTLING CATEGORIES DATA) S0701450 

9037 F0RMAT((22X,9(F5.4,1H,),F5.4)) S0701460 

9038 F0RMAT(30H METEOROLOGICAL DATA SOUNDING, 4 IX, 3A2) S0701470 

9039 FORMAT (7X,45HAVERAGE PARTICLE SIZE DIAMETERS (MICROMETERS), S0701480 

1 20X,F5.2) S0701490 

CF QUESTION FORMAT STATEMENTS SO 70 1500 

9040 F0RMAT(33H PRINT DETAIL MODEL PARAMETERS? ( , 2A2 , IHN, 2A2 , 1H0,2A2 , S0701510 

*1H,,2A2.1HY,2A2,5HES):_) S0701520 

9041 FORMAT ( 2 A2.19H PRINT OUT WILL BE:,38X,4A2) S0701530 


9028 FORMAT (33H 

9029 FORMAT (4 IH 

9030 FORMAT(23H 

9031 FORMAT (23H 

9032 FORMAT(23H 
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9042 FORMATdH , 2A2 , 1 IHPLEASE WAIT.2A2.26H - TAPE SEARCH IN PROGRESS) S0701540 

9043 FORNAT(2A2) S0701550 

9044 FORMAT (2A2,53HDO YOU WISH RESULTS FOR ANOTHER CALCULATION HEIGHT7S0701560 

* (,2A2,1HY,2A2,2HES,2A2,1H,,2A2,1HN,2A2,4H0):_) S0701570 

9045 FORMAT (2A2,53HDO YOU WISH TO PROCESS ANOTHER METEOROLOGICAL CASE7S0701580 

* (,2A2,1HY,2A2,2HES,2A2,1H, ,2A2,1HN,2A2,4H0):_) S0701590 

9046 FORMAT (2A2.30H REEDM HAS TERMINATED NORMALLY) S070L600 

9047 FORMAT (2A2.39H NOTE: REEDM HAS TERMINATED ABNORMALLY) S0701610 

9048 F0RMAT(22H ENTER RAINFALL RATE ( , 2A2 , IHH, 2A2 ,8HEAVY=0. 3, 2A2 , IH, , S0701620 

*2A2 , IHM , 2A2 , 1 2H0DERATE=0 . 2 , , 2A2 , IHL, 2A2 , 9HIGHT=0 . 1 , , 2A2 , IHA, 2A2 , S070 1 630 

*9HN0THER) :_) S0701640 

9049 FORMAT (2A2, 4 OH ENTER RAINFALL RATE (INCHES PER HOUR) :_) S0701650 

9050 F0RI-1AT(2A2,33H RAINFALL RATE (INCHES PER HOUR):, 24X.F8.2) S0701660 

9051 FORMAT (4 IH RAINFALL SCAVENGING COEFFICIENT (LAMBDA= , 2A2 , 1PE12. 5 , S0701670 

*2A2,10H) CHANGE ( , 2A2 , IHN, 2A2, IHO, 2A2 , IH, , 2A2, IHY, 2A2 , 5HES) :_) S0701680 

9052 FORMAT ( 2 A2.16H ENTER LAMBDA:_) S0701690 

9053 FORMAT ( 2 A2,33H RAINFALL SCAVENGING COEFFICIENT: , 20X, 1 PE 12. 5) S0701700 

9054 FORMAT (37H TIME RAIN STARTS AFTER LAUNCH (TIM1=, 2A2.F6. 2 , 2A2 , S0701710 

*18H SECONDS) CHANGE? (, 2A2 , IHN, 2A2, IHO, 2A2, IH, , 2A2 , IHY, 2A2 ,5HES) :_)S0701720 

9055 FORMAT(2A2,23H ENTER TIMl (SECONDS) :_) S0701730 

9056 F0RMAT(2A2,41H TIME RAIN STARTS AFTER LAUNCH (SECONDS) :, 18X.F6. 2) S0701740 

9057 FORMAT(22H RAIN DURATION (DURAT=,2A2,F6.2,2A2,17H HOURS) CHANGE? (S0701750 


* , 2A2 , IHN , 2A2 , IHO , 2A2 , IH , , 2A2 , IHY , 2A2 , 5HES) :_) 

9058 FORFIAT(2A2,22H ENTER DURAT (HOURS) :_) 

9059 FORMAT(2A2,23H RAIN DURATION (HOURS) : ,36X,F6.2) 

9060 F0RMAT(12H CALCULATE ( , 2A2 , IHM, 2A2 , 15HAXIMUM POSSIBLE, 2A2, IH, , 
*2A2,1HT,2A2,36RIME-DEPENDENT) WASHOUT DEPOSITION? :_) 

9061 FORMAT (2A2,23H WASHOUT DEPOSITION IS: , 26X, 16HMAXIMUM POSSIBLE) 

9062 FORMAT(2A2,23H WASHOUT DEPOSITION IS: ,28X, 14HTIME-DEPENDENT) 

9063 FORMAT (2A2, 6 IH DO YOU WISH TO CHANGE WASHOUT DEPOSITION CALCULI 
*N TYPE? (,2A2,1HY,2A2,2HES,2A2,1H,,2A2,1HN,2A2,4H0):_) 

C TYPE AND DIMENSION STATEMENTS 

INTEGER P0(8) 

DIMENSION INPT(IO) ,LC(12) 

C 

EQUIVALENCE ( INPT ( 1 ) , INPT 1 ) 

Q DATA STATEMENTS 

DATA LC/2H39,1HA,2H39,1HB,2H39,1HC,2H40,1H ,2H41,1H ,2H17,1H / 
DATA P0/2H S,2HUM,2HMA,2HRY, 

2HDE, 2HTA, 2HIL, 2HED/ 

DATA IHT/1HT/,IHA/1HA/, 

* IHH/ IHH/, IHL/ IHL/, IHM/ IHM/ 

DATA IIHTI/2HTI/, 

* IIHAN/2HAN/, 

* IIHMA/2HMA/,IIHHE/2HHE/,IIHM0/2HM0/, 

* IIHLI/2HLI/ 

DATA IESM/15515B/,IESA/15501B/,IESJ/15512B/,IESD/15504B/, 

* INVBL/62103B/ 

DATA JVERSN/8213/ 


IF (IVERSN .NE. JVERSN) CALL LOADS (-1 ,0,0, 0,0, BATCH) 
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IF (PLUS(745) .NE. -9925.0) GO TO 30 
C LOCK PRINT OUTPUT UNIT 

1 = 0 

DO 20 K=2,5 

IF (IPAR(K) .EQ. ICU.OR. IPAR(K) .LE. 0) GO TO 20 
J = IFTTY(IPAR(K)) 

IF (J .LT. 0) GO TO 20 
DO 10 J=2,K 

IF (IPAR(K) .EQ. IPAR(J-l)) GO TO 20 
10 CONTINUE 
1 = 1+1 

IFRMT(I) = IPAR(K) 

20 CONTINUE 

IF (I .GT. 0) CALL LURQ(1 , IFRMT, I) 

PLUS(745) =0.0 
30 IF (CRT) GO TO 40 
lESM = NULL 
lESA = NULL 
lESJ = NULL 
lESD = NULL 
INVBL = NULL 
40 CONTINUE 
C 

C DETERMINE ENTRY POINT. 

NNNEST = 2 

GOTO (50,650,690,810,660,700,800), NNNTRY 
50 CONTINUE 
C 

60 CONTINUE 

IF(.NOT.MODEL5) GOTO 550 


C ENTER INPUT PARAl-IETERS FOR MODEL 5 OPTION. 

C ENTER MAXIMUM POSSIBLE WASHOUT DEPOSITION OPTION. 


IF (.NOT. BATCH) GOTO 70 
READ(IIU,9001) INPTl 
GOTO 100 

70 URITE(ICU,9060) INVNDR, INV,OFF,ULINE,OFF 
INPTl = IBLNK 
READ (IIU, 9001) INPTl 
IF (INPTl .NE. MINUS 1) GOTO 90 
IFdAGAIN .EQ. 1) GOTO 730 
WRITE(ICU,9003) lESCAJ.IESCAJ 
- IF(IRUN .LT. 3) GOTO 830 

80 IF(.NOT. GRVSET) GOTO 840 
N = 4 . 

IF(NVS .GT. 1) N = 5 

IF(NVS .GT. 11) N = 6 

WRITE (ICU,9003) (IESCAJ,I=1 ,N) 

GOTO 850 

90 IFdNPTl .EQ. MINUS9) GOTO 860 

100 IF (INPTl .EQ. IHT. OR. INPTl .EQ. IIHTI) GO TO 110 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IHM. OR. INPTl. EQ.IIHMA) GO TO 120 
WRITE (ICU,9002) INV, OFF, 13,0 


S0702060 

S0702070 

S0702080 

S0702090 

S0702100 

S0702110 

S0702120 

S0702130 

S0702140 

S0702150 

S0702160 

S0702170 

S0702180 

S0702190 

S0702200 

S0702210 

S0702220 

S0702230 

S0702240 

S0702250 

S0702260 

S0702270 

S0702280 

S0702290 

S0702300 

S0702310 

S0702320 

S0702330 

S0702340 

S0702350 

S0702360 

S0702370 

S0702380 

S0702390 

S0702400 

S0702410 

S0702420 

S0702430 

S0702440 

S0702450 

S0702460 

S0702470 

S0702480 

S0702490 

S0702500 

S0702510 

S0702520 

S0702530 

S0702540 

S0702550 
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S0702570 


53 




IF (BATCH) CO TO 800 

S0702580 


GO TO 70 

S0702590 

110 

IF (.NOT. BATCH) WRITE (ICU, 9062) lESA.IESJ 

S0702600 


MAXDEP = .FALSE. 

S0702610 


GOTO 130 

S0702620 

120 

IF (.NOT. BATCH) WRITE (ICU, 9061) IESA,IESJ 

S0702630 


MAXDEP = .TRUE. 

S0702640 

130 

CONTINUE 

S0702650 


IFdAGAIN .EQ. 1) GOTO 370 

S0702660 

C 

ENTER RAINFALL RATE. 

S0702670 


IF(BATCH) GOTO 150 

S0702680 

140 WRITE(ICU,9048) TNVNBR, INV,0FF,ULINE,0FF,ULINE,0FF,ULINE,0FF 

S0702690 

150 

INPTl = IBLNK 

S0702700 


CALL IFNBR(INPT,10,IER,IIU) 

SO70271O 


IF (BATCH) GOTO 170 

S0702720 


IFdNPTl .NE. MINUSl) GOTO 160 

S0702730 


TOITE(ICU,9003) IESCAJ,IESCAJ 

S0702740 


GOTO 70 

S0702750 

160 

IF(INPT1 .EQ. MINUS9) GOTO 860 

S0702760 

170 

IF (INPTl .EQ. IBLNK. OR. INPTl .EQ. IIHHE) INPTl = IHH 

S0702770 


IF (INPTl .EQ. IIHMO) INPTl - IHM 

S0702780 


IF (INPTl .EQ. IIHLI) INPTl = IHL 

S0702790 


IF (INPTl .EQ. IIHAN) INPTl - IHA 

S0702800 


IFdNPTl .EQ. IHH) GOTO 260 

S0702810 


IFdNPT .NE. IHM) GOTO 180 

S0702820 


RAINRT =0.2 

S0702830 


GOTO 260 

S0702840 

180 

IFdNPT .NE. IHL) GOTO 190 

S0702850 


RAINRT =0.1 

S0702860 


GOTO 260 

S0702870 

190 

IF (INPTl .EQ. IHA) GO TO 210 

S0702880 


IF dER .EQ. 0) GO TO 200 

S0702890 


WRITE (ICU, 9002) INV, OFF, 14,0 

S0702900 


IF (BATCH) GO TO 800 

S0702910 


GO TO 140 

S0702920 

200 

CALL CODE (20) 

S0702930 


READ(INPT,*) RAINRT 

S0702940 


IF(RAINRT .LE. 0.0) RAINRT =0.3 

S0702950 


IF (.NOT. BATCH) GO TO 270 

S0702960 


GOTO 280 

S0702970 

210 WRITE (ICU, 9049) lESA.IESJ 

S0702980 


RNPT =0.0 

S0702990 


CALL IFNBR(IFRMT,14,IER,IIU) ' 

S0703000 


IF (lER .EQ. 0) GO TO 230 

S0703010 

220 

WRITE (ICU, 9002) INV, OFF, 14,1 

S0703020 


IF (BATCH) GO TO 800 

S0703030 


GO TO 210 

S0703040 

230 

CALL CODE (80) 

S0703050 


READ (IFRMT,*) RNPT 

S0703060 


IF (RNPT .EQ. MINSl) GO TO 240 

S0703070 


IF (RNPT .EQ. MINS9) GO TO 860 

S0703080 


IF (RNPT .GE. 0.0) GO TO 250 

S0703090 
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GO TO 220 

240 TOITE(ICU,9003) lESCAJ 
GOTO 140 

250 IF(RNPT .GT. 0.0) RAINRT = RNPT 
260 IF(BATCH) GOTO 280 
270 17RITE(ICU,9050) lESA, lESJ, RAINRT 
280 LAMBDA = 5 . 2E-4*RAINRT**. 567 
IF(IRUN .LT. 3) GOTO 370 

ENTER RAINFALL SCAVENGING COEFFICIENT. 

290 WRITE (ICU, 9051) INV, LAMBDA, OFF, INVNDR,INV,OFF,ULINE, OFF 
INPTl = IBLNK 


READ(IIU,9001) INPTl 
IFdNPTl .NE. MINUSl) GOTO 300 
I7RITE( ICU, 9003) lESCAJ, lESCAJ 
GOTO 140 

300 IFCINPTI .EQ. MINUS9) GOTO 860 

IF (INPTl . EQ. IBLNK. OR. INPTl . EQ. INJ. OR. INPTl . EQ. INOJ) 
IF (INPTl .EQ. lYSJ. OR. INPTl .EQ. lYESJ) GO TO 310 
WRITE (ICU, 9002) INV, OFF, 14,2 
IF (BATCH) GO TO 800 
GO TO 290 

310 WRITE(ICU,9052) IESA,IESJ 
RNPT =0.0 


GO TO 360 


CALL IFNBR(IFRMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 330 
320 WRITE (ICU, 9002) INV, OFF, 14,3 
IF (BATCH) GO TO 800 
GO TO 310 
330 CALL CODE (80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 340 
IF (RNPT .EQ. MINS9) GO TO 860 
IF (RNPT .GE. 0.0) GO TO 350 
GO TO 320 

340 WRITE(ICU,9003) lESCAJ 
GOTO 290 

350 IF(RNPT .GT. 0.0) LAMBDA = RNPT 
360 WRITE(ICU,9053) lESA, lESJ, LAMBDA 
370 CONTINUE 


IF(MAXDEP) GOTO 460 

ENTER TIME RAIN STARTS AFTER LAUNCH. 

IF (.NOT. BATCH) GOTO 380 
TIMl =0.0 
READdIU,*) TIMl 
TIMl = AMAXl (TIMl, 0.0) 

GOTO 460 

380 WRITE(ICU,9054) INV, TIMl, OFF, INVNDR, INV, OFF, ULINE, OFF 
INPTl = IBLNK 
READdIU, 900.1) INPTl 
IFdNPTl .NE. MINUSl) GOTO 390 
WRITE(ICU,9003) lESCAJ, lESCAJ 
IF(IAGAIN .EQ. 1) GOTO 70 


S0703100 

S0703110 

S0703120 

S0703130 

S0703140 

S0703150 

S0703160 

S0703170 

S0703180 

S0703190 

S0703200 

S0703210 

S0703220 

S0703230 

S0703240 

S0703250 

S0703260 

S0703270 

S0703280 

S0703290 

S0703300 

S0703310 

S0703320 

S0703330 

S0703340 

S0703350 

S0703360 

S0703370 

S0703380 

S0703390 

S0703400 

S0703410 

S0703420 

S0703430 

S0703440 

S0703450 

S0703460 

S0703470 

S0703480 

S0703490 

S0703500 

S0703510 

S0703520 

S0703530 

S0703540 

S0703550 

S0703560 

S0703570 

S0703580 

S0703590 

S0703600 

S0703610 
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IFdRUN .LT. 3) GOTO 140 
. GOTO 290 

390 IFdNPTl .EQ. MINUS9) GOTO 860 

IF ( INPT 1 . EQ . IBLNK . OR . INPT 1 . EQ . INJ . OR. INPTl . EQ . INOJ ) 
IF (INPTl .EQ. lYSJ. OR. INPTl .EQ. lYESJ) GO TO 400 
TOITE (ICU,9002) INV, OFF, 15,0 
IF (BATCH) GO TO 800 
GO TO 380 

400 WRITEdCU, 9055) IESA,IESJ 


GO TO 450 


RNPT =0.0 

CALL IFMBR(IFRiMT,14,IER,IIU) 

IF (lER .EQ. 0) GO TO 420 
410 WRITE (ICU,9002) INV, OFF, 15,1 
IF (BATCH) GO TO 800 
GO TO 400 
420 CALL CODE(80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 430 
IF (RNPT .EQ. MINS9) GO TO 860 
IF (RNPT .GE. 0.0) GO TO 440 
GO TO 410 

430 WRITE(ICU,9003) lESCAJ 
IFdAGIN .EQ. 1) GOTO 70 
GOTO 380 

440 IF (RNPT .GT. 0.0) TIMl = RNPT 
450 WRITEdCU, 9056) lESA, IESJ,TIM1 
460 CONTINUE 

IFdAGAIN .EQ. 1) GOTO 680 

ENTER RAIN DURATION, DURAT. 

IF (.NOT. BATCH) GOTO 470 
READdIU,*) DURAT 
. IF(DURAT .LE. 0.0) DURAT =1.0 
GOTO 550 

470 WRITEdCU, 9057) INV, DURAT, OFF, INVNDR, INV, OFF, ULINE, OFF 
INPTl = IBLNK 
READ(IIU,9001) INPTl 
IF (INPTl .NE. MINUS 1) GOTO 480 
WRITE (ICU, 9003) IESCAJ,IESCAJ 
IF(.NOT.MAXDEP) GOTO 380 
IF(IRUN .LT. 3) GOTO 140 


GOTO 290 

480 IFdNPTl .EQ. MINUS9) GOTO 860 

IF (INPTl. EQ. IBLNK. OR.INPTl.EQ. INJ. OR. INPTl. EQ. INOJ) GO TO 540 
IF (INPTl .EQ. lYSJ. OR. INPTl .EQ. lYESJ) GO TO 490 
WRITE (ICU, 9002) INV, OFF, 16,0 
IF (BATCH) GO TO 800 
GO TO 470 

490 WRITE(ICU,9058) IESA,IESJ 


RNPT =0.0 

CALL IFNBRdFRMT, 14,IER,IIU) 
IF (lER .EQ. 0) GO TO 510 
500 WRITE (ICU, 9002) INV, OFF, 16,1 


S0703620 

S0703630 

S0703640 

S0703650 

S0703660 

S0703670 

S0703680 

S0703690 

S0703700 

S0703710 

S0703720 

S0703730 

S0703740 

S0703750 

S0703760 

S0703770 

S0703780 

S0703790 

S0703800 

S0703810 

S0703820 

S0703830 

S0703840 

S0703850 

S0703860 

S0703870 

S0703880 

S0703890 

S0703900 

S0703910 

S0703920 

S0703930 

S0703940 

S0703950 

S0703960 

S0703970 

S0703980 

S0703990 

S0704000 

S0704010 

S0704020 

S0704030 

S0704040 

S0704050 

S0704060 

S0704070 

S0704080 

S0704090 

S0704100 

S0704110 

S0704120 

S0704130 
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IF (BATCH) GO TO 800 
GO TO 490 
510 CALL CODE (80) 

READ (IFRMT,*) RNPT 
IF (RNPT .EQ. MINSl) GO TO 520 
IF (RNPT .EQ. MINS9) GO TO 860 
IF (RNPT .GE. 0.0) GO TO 530 
GO TO 500 

520 WRITE(ICU,9003) lESCAJ 
GOTO 470 

530 IF(RNPT .GT. 0.0) DURAT = RNPT 
540 WRITE(ICU,9059) lESA, lESJ, DURAT 
550 CONTINUE 

IF(IRUN .LT. 3) GOTO 590 

C DETAILED OR SUMMARY PRINT OUT? 

560 WRITE(ICU,9040) INVNDR,INV,OFF,ULINE,OFF 
INPTl = IBLNK 
READ(IIU,9001) INPTl 
IF(INPT1 .NE. MINUSl) GOTO 570 
URITE(ICU,9003) lESCAJ, lESCAJ 
1F(M0DEL5) GOTO 470 
GOTO 80 
570 IDXPO=4 

IF (INPTl .EQ. MINUS9) GO TO 860 
IF UNPTl.EQ. IBLNK. OR. INPTl. EQ.INOJ) INPTl = INJ 
IF UNPTI.EQ.IYESJ) INPTl = lYSJ 
CALL ANSW(9,INPT,IPRINT,IDXPO,IER) 

IF (lER .EQ. 0) GO TO 580 
WRITE (ICU,9002) INV,OFF,16,2 
IF (BATCH) GO TO 800 
GO TO 560 

580 WRITE(ICU,9041) lESA.IESJ, (PO(I) ,I=IDXP0,IDXP0+3) 
590 IF(IRUN.EQ.2) IPRINT=2 


C DO LOOP ON THE RUN NUMBER 

600 CONTINUE 

C LOCK OUTPUT DEVICE. 


WRITE (lOU, 9004) IVERSN.LOCATN 
WRITE(IOU,9005) TITLE 

WRITE ( lOU , 900 6 ) LTIME , LSDT ( 1 ) , LSDT ( 2 ) , LDAY , LMON ( 1 ) , LMON ( 2 ) , LYEAR 
WRITE(IOU,9007) JTIME.LSDTO) ,LSDT(2) , JDAY, JMON(l) , JM0N(2) .JYEAR 
WRITE(IOU,9008) 

WRITE(IOU,9009) MDLNAM 
WRITE(IOU,9038) FILE 

WRITEaOU,9010) (RT(I) ,I=IDXRT,IDXRT+5) 

WRITE(IOU,9011) (TITLE(I),I=1,7) 

WRITEUOU,9012) (TITLED) , 1=8 , 14) 

I = 2*LSITE-1 

WRITE(IOU,9013) LC(I) ,LC(I+1) 

IF(.N0T.M0DEL6) WRITE(IOU, 9014) ( (ICHAR(I+12-3*J) , 1=1 , 3) , J=1 ,4) 
WRITE(IOU,9015) (CS(I) , I=IDXCS , IDXCS+4) 

IF(.NOT.MODEL4) GOTO 610 

IF(ICALC.LT.3) WRITE(IOU,9016) (CL(I) ,I=IDXCL,IDXCL+6) 


S0704140 

S0704150 

S0704160 

S0704170 

S0704180 

S0704190 

S0704200 

S0704210 

S0704220 

S0704230 

S0704240 

S0704250 

S0704260 

S0704270 

S0704280 

S0704290 

S0704300 

S0704310 

S0704320 

S0704330 

S0704340 

S0704350 

S0704360 

S0704370 

S0704380 

S0704390 

S0704400 

S0704410 

S0704420 

S0704430 

S0704440 

S0704450 

S0704460 

S0704470 

S0704480 

S0704490 

S0704500 

S0704510 

S0704520 

S0704530 

S0704540 

S0704550 

S0704560 

S0704570 

S0704580 

S0704590 

S0704600 

S0704610 

S0704620 

S0704630 

S0704640 

S0704650 
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IF(ICALC.EQ.3) URITE(I0U,9017) CALHT 
610 CONTIiniE 

WRITE(IOU,9018) TPROPC 
IF (.NOT. MODELS) GOTO 620 
IF(.NOT.MAXDEP) WRITE (lOU, 903 1) 

IF(MAXDEP) WRITE (lOU, 9032) 

WRITE (lOU, 902 7) RAINRT 
IF(.NOT.MAXDEP) WRITE(IOU, 9029) TIMl 
WRITE(IOU,9030) DURAT 
620 CONTINUE 

IF(IPRINT.EQ.2) GO TO 630 
WRITE(IOU,9019) 

IF(MODEL4) WRITE(IOU,9020) TIMAV 
IF(MODELA) WRITE ^OU, 9021) DECAY 
IF(GASSET) WRITE(IOU,9022) GAMMAP(21) 
WRITE(IOU,9023) ALPHA, BETA 
WRITE ( lOU , 9024 ) GAMMAX , GAMIIAY , GAMMAZ 
WRITE(IOU,9025) XRY.XRZ 
IF(MODEL5) WRITE(IOU,9028) LAMBDA 
IF(MODEL5 .OR. .NOT.GRVSET) GOTO 630 
WRITE (lOU, 9036) 

WRITE (lOU, 9033) NVS,VS(1) 

IF(NVS .GT. 1) WRITE (lOU, 9037) (VS (I) , 1=2 ,NVS) 
WRITE(IOU,9034) GAMMAP(l) 

IF(NVS .GT. 1) WRITE(I0U,9037) (GAMMAP(I) , 1=2 ,NVS) 
17RITE(IOU,9035) FS(1) 

IF(NVS .GT. 1) WRITE(I0U,9037) (FS (I) , 1=2 ,NVS) 
IF(.N0T.M0DEL6) GOTO 630 
WRITE (lOU, 9039) DBAR(l) 

IF(NVS .GT. 1) WRITE(IOU,9037) (DBAR(I) , 1=2 ,NVS) 
630 CONTINUE 


C UNLOCK OUTPUT DEVICE. 

IF (BATCH .OR. IPLACE.NE.2) GO TO 640 
WRITE(ICU,9042) OFF(l) ,INVBL,OFF 
640 CONTINUE 

C TRANSFER TO PROGRAM RDATM TO READ METEOROLOGICAL DATA 


NNNTRY = 1 
CALL REEDM 
C 

650 CONTINUE 

ALTSV=ALT(1) 

IF(IFLG.LT.O) GO TO 790 

C-. TRANSFER TO THE PROGRAM RCLDM — THE CLOUD RISE PROGRAM 

660 IF(IAGAIN.EQ.O) GO TO 670 
IAGAIN=0 
ALT(1)=ALTSV 
ICALC=3 

670 NNNTRY = 2 
CALL REEDM 
C 

680 NNNTRY = 6 
CALL REEDM 
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c 


690 RUMNUM = RUNNUM + 1 

IF(RUNNUM .LE. NUMRUN) GOTO 600 
IF(IRUN .EQ. 1) GOTO 770 

C ANOTHER CALCULATION HEIGHT 

IF(,N0T.M0DEL4) GOTO 730 
IF(BATCH) GOTO 710 

700 WRITE(ICU,9044) lESA, lESM.INVNDR 
710 INPTl = IBLNK 


S0705180 
S0705190 
S0705200 
S0705210 
S0705220 
S0705230 
S0705240 

INV.OFF.ULINE.OFF S0705250 

S0705260 
S0705270 
S0705280 
S0705290 
S0705300 
S0705310 
S0705320 
S0705330 
S0705340 
S0705350 
S0705360 
S0705370 
S0705380 
S0705390 
S0705400 
S0705410 
S0705420 
S0705430 
S0705440 
S0705450 
S0705460 
S0705470 
S0705480 
S0705490 
S0705500 
S0705510 
S0705520 
S0705530 
S0705540 
S0705550 
S0705560 
S0705570 
S0705580 
S0705590 
S0705600 
S0705610 
S0705620 
S0705630 
S0705640 
S0705650 
S0705660 
S0705670 
S0705680 
S0705690 


READ(IIU,9001) INPTl 

IF(. NOT. BATCH. AND. (INPTl . EQ.MINUSl. OR. INPTl. EQ.MINUS9) ) GOTO 790 
IF ( INPTl. EQ.INJ. OR. INPTl. EQ.INOJ) GO TO 730 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 720 
IF (BATCH) GO TO 730 
WRITE (ICU.9002) INV, OFF, 24,0 
GO TO 700 
720 IAGAIN=1 
KEEP = 1 

IF (BATCH) GOTO 870 
GO TO 880 
730 CONTINUE 

IF (.NOT. MODELS) GOTO 770 

C ANOTHER WASHOUT DEPOSITION CALULATION TYPE. 

lAGAIN = 0 
IF (BATCH) GOTO 750 

740 WRITE(ICU,9063) lESA, lESJ, INVNDR, INV,OFF,ULINE,OFF 
750 INPTl = IBLNK 

READ(IIU,9001) INPTl 

IF (.NOT. BATCH. AND. (INPTl . EQ.MINUSl . OR. INPTl . EQ.MINUS9) ) GOTO 790 

IFdNPTl. EQ.INJ. OR. INPTl. EQ.INOJ) GO TO 770 

IF (INPTl. EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 760 

WITE (ICU,9002) INV, OFF, 25,0 

IF (BATCH) GO TO 800 

GO TO 740 

760 IF (.NOT. BATCH) WRITE (ICU,9003) lESCAJ 
lAGAIN = 1 
IF (BATCH) GOTO 60 
WRITE(ICU,9043) IESA,IESD 
GOTO 60 
770 CONTINUE 

IF(BATCH) GOTO 780 

WRITE ( ICU , 904 5 ) lES A , lESM , INVNDR , INV , OFF , ULINE , OFF 
780 INPTl = IBLNK 

READ(IIU,9001) INPTl 

IF(. NOT. BATCH. AND. (INPTl. EQ.MINUSl. OR. INPTl. EQ.MINUS9)) GOTO 790 
IF(INPT1.EQ. IBLNK. OR. INPTl. EQ.IYSJ. OR. INPTl. EQ.IYESJ) GO TO 860 
GOTO 810 

C PROGRAM RESTART - REWIND MET TAPE 

790 IF(IPLACE.EQ.2) CALL EXEC(3,410B) 

GO TO 860 

800 lERROR(l) = MINSl 

WRITE (ICU, 9047) lESA.IESM 
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GOTO 820 

C PROGRAM TERMINATION. 

810 WRITE (ICU,9046) lESA.IESM 
C 

820 CONTINUE 

TOITE(IOU,9026) 

STOP 

830 NNNTRY = 5 
GO TO 890 
840 NNNTRY = 6 
GO TO 890 
850 NNNTRY = 7 
GO TO 890 
860 NNNTRY = 1 
GO TO 890 
870 NNNTRY = 8 
GO TO 890 
880 NNNTRY = 9 
890 NNNEST = 1 
CALL REEDM 
END 


S0705700 
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S0705720 
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S0705740 

S0705750 

S0705760 

S0705770 

S0705780 
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S0705800 
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10 


20 


SUBROUTINE ANS W ( IDX , I ALF , JDX , KDX , lER) 
. , UPDATE: 8213 SOURCE: 02 APR 82 

INTEGER VARP^AY (4,11), INTNMB (4,11) 
DATA VARRAY/lHO, IHR, IHP, IHD, 

1HS,1HT,2HD2,2HD3, 

1HN,1HS,1HC,2HXX, 

1IIH,1H0,1HC,1HA, 

2H39,2H17,2H40,2H41, 

1HS,2HST,1HA,2HXX, 

1HE,1HS,2HXX,2HXX, 

1HU,1HL,2HXX,2HXX, 

1HN,1HY,2HXX,2HXX, 

IHN, 1HY,2HXX,2HXX, 
lHC,im^,lHG,2H-l/ 

DATA INTNMB/2,3,1,4, 

1 . 2 , 3 , 4 , 

1,2, 3,0, 

1 . 2 , 3 , 4 , 

1HS,1HD,1HT,1HT, 

1,2, 3,0, 


2 , 1 , 0 , 0 , 

1 , 2 , 0 , 0 , 

2 , 1 , 0 , 0 , 

1 . 2 , 0 , 0 , 

1,2, 3.0/ 

DATA MINUS9/2H-9/ 
lER = 0 
DO 10 1=1,4 

IF(IALF.EQ.VARRAY(I,IDX)) GO TO 40 
CONTINUE 


IF(IALF.EQ.MINUS9) GO TO 20 
lER = 1 
GO TO 30 


JDX=-1 


GO TO 50 
30 1=1 

40 JDX=INTNMB(I,IDX) 
KDX=KDX*I-KDX+1 
50 RETURN 
END 


LOCATION: 


KSC 


S0800000 

S0800010 

S0800020 

S0800030 

S0800040 

S0800050 

S0800060 

S0800070 

S0800080 

S0800090 

S0800100 

S0800110 

S0800120 

S0800130 

S0800140 

S0800150 

S0800160 

S0800170 

S0800180 

S0800190 

S0800200 

S0800210 

S0800220 

S0800230 

S0800240 

S0800250 

S0800260 

S0800270 

S0800280 

S0800290 

S0800300 

S0800310 

S0800320 

S0800330 

S0800340 

S0800350 

S0800360 

S0800370 

S0800380 
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onoonooooo 


REEDMSOURCE MODULE &RDATM 


FTN4 

PROGRAM RDATM(5) 

UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 


ORGANIZATION: H. E. CRAMER CO. , INC. 

WORK FOR; DR. J. B. STEPHENS (ES84) 

PROGRAM CODE: RDATM 

PROGRAM DESCRIPTION: ONE OF THE MODLTLES FOR ROCKET EXHAUST 

EFFLUENT DIFFUSION ANALYSIS (MULTI-LAYER) 

INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS 

OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS, PLOTS 


^ ************************************************************* 

c * * 

C * NASA/MSFC MULTILAYER DIFFUSION MODEL ~ 30 OCT 1978 * . 

c * ! 

c * METEOROLOGICAL INPUT PROGRAM — RDATM * 

c * 

C ************************************************************* 

Cc 

C**** BEGIN COMMON AREA 

C 04/02/82 

C ^MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C— : INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MOD EL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , I S IG , ICALC , CALHT , 

' IPLACE , IPRINT , SIGMAR , SIGNER, LSITE , BOTLAY , 

i ZRK , DECAY , GOOD , NCISO , NDI SO , NTISO , FILE (3) 

, RAINRT , LAMBDA , T IM 1 , DURAT , NVS , I VERSN , LOCATN ( 2 ) 
,ipllntU) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DISO(10) , 
! TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 

FS(20) ,MDLNAM(12) ,DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS ,M0DEL6 


S090000C 
S0900010 
S0900020 
: S0900030 

: S0900040 

: S0900050 

: S0900060 

: S0900070 

: S0900080 

: S0900G90 

: S0900100 

: S0900110 

: S0900120 

: S0900130 

: S0900140 

: S0900150 

: S0900160 

: S0900170 

: S0900180 

: S0900190 

: S0900200 

; S0900210 

S0900220 
S0900230 
S0900240 
S0900250 
S090’0260 
S0900270. 
S0900280 
S0900290 
S0900300 
****80900310 
S0900320 
S0900330 
S0900340 
S0900350 
S0900360 
S0900370 
S0900380 
S0900390 
S0900400 
S0900410 
S0900420 
S0900430 
S0900440 
S0900450 
S0900460 
S0900470 
S0900480 
S0900490 
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INTEGER RUNNUM,RT,CL,CS S0900500 

COMMON /CTREE/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S0900510 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , S I GXNK , S IGYNK , S0900520 

S IGZ , I SNDFO , CRT , LAYTOP (3 ) , ITDU , KEEP S 0 9 0 0 5 3 0 

, MIXING, MAXDEP.LAYBOT (3) • S0900540 

, ALTSV , BATCH , CL (1 4 ) , CS ( 1 0) , GASSET , I AGAIN , . SO 9 00 5 5 0 

ICHARC12) ,IDXCL,IDXCS,IERR0R(5),IFP1IT(80), S0900560 

MINUS 1.MINUS9, MINS 1.MINS9, S0900570 

MODEL 4 , MODEL 5 , MODEL6 , NNNEST , MNNTRY , LLNEST , LLNTRY , S0900580 

RT(24),TPROPC,IDXRT S0900590 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S0900600 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S0900610 

TAB,TAB2,SETTAB,CLRTAB,CURSUP.CURSDN,CURLFT,CLRDSP, S0900620 

CLRLNE.INSLNE, DELINE S0900630 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) , INV(2) ,INVHF(2) , S0900640 

INVNDR(2) ,ULINE(2) , S0900650 

TAB , TAB 2 , S ETTAB , CLRTAB , CURSUP , CURSDN ,CURLFT,CLRDSP,S0900660 
CLRLNE.INSLNE, DELINE, S0900670 

IESCAJ(3),NULL,IBLNK. S0900680 

IPAR(5),ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S0900690 

C VEHICLE PARAMETERS S0900700 

COMMON /VCLPR/ VPAR(17) S0900710 

C time PARAMETERS S0900720 

COMMON /TIME/ JTIME, JDAY, JYEAR, ISTIME, ISDAY.ISYEAR.LTIME, S0900730 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S0900740 

C SOUND ING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S0900750 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S0900760 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S0900770 

C LAYER PARAMETERS S0900780 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S0900790 

. SIGYO(29) S0900800 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S0900810 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S0900820 

C CALCULATED NEW LAYER PARAMETERS S0900830 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) , SIGEPN(32) , S0900840 
. SPEEDN(32) S0900850 

C CONVERSION FACTORS S0900860 

COMMON /CNVRT/ QC0NV(4) .QPDEPH S0900870 

^ S0900880 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S0900890 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S0900900 

READ /WRITE BUFFER ' S0900910 

A R R A Y - 2077 +1 + 1 + 2 * 900 = 3879S0900920 

C*************************************************-k***********!**********s0900930 

C - 


C 

C**** 


REAL MAXHGT 

EQUIVALENCE STATEMENTS 

EQUIVALENCE ( I lU , IPAR ( 1 )),( lOU , IPAR( 2) ),( IPUl , IPAF. ( 3 ) ) 
, (IPU2 , IPAR(4) ) , (IPU3. IPAR(5) ) 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) 

END OF COMMON AREA 


S0900940 
S0900950 
S0900960 
S0900970 
S0900980 
S0900990 
S0901000 
****S0901010 
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cc 

CF INPUT FORIIAT STATEMENTS 

9001 FORMAT (14 , 3X12 , 1XA2 ,A1 , 1X14) 

9002 FORMAT (F6 . 0 , 1XF3 . 0 , 1X,F3 . 0 ,F6. 1 ,F6. 1 ,F8. 2 , 1XF3. 0, 7XF7 . 2) 

9003 FORMAT^ (F6.2) 

9004 FOR]MAT (12) 

9005 FORMAT (A2) 

CF 

CF OUTPUT FORMAT STATEMENTS 

9006 F0R1‘1AT(1H1,22(1H*),11X,19HMETECR0L0GICAL DATA, 10X.22 (IH*) // 

5X.11HRUN NUMBER: ,14, 10X.33H USING METEOROLOGICAL DATA FILE: ,3A2/S0901120 

^ . S0901130 

9007 'format (6 IH ** MAXIMUM DATA FILE NUMBER IS 99 - PROCESSING TERMINATS0901 140 
.ES **,5X,3A2) S0901150 

9008 FORMAT (33H0*** REEDM ERROR Oil, OPEN ERROR ,I4,18H ON SOUNDING FIS0901160 

*LE ,3A2) S0901170 

9009 EORMAT (34H0*** REEDM ERROR 012, READF ERROR ,I4,18H ON SOUNDING FS0901180 


S0901020 

S0901030 

S0901040 

S0901050 

S0901060 

S0901070 

S0901080 

S0901090 

S0901100 

S0901110 


*ILE ,3A2) 

9010 FORMAT (6X,40A2) 

9011 FORMAT (IHl , 5X, 6HTIME: ,I4 , 2A2 ,4X, 6HDATE: ,12, 1X,A2,A1 , 1X,I4) 

9012 F0RMAT(//1X,22(1H*),16X,8HS0UNDING,16X,22(1H*)//) 

90 1 3 FORMAT ( / / 1 X , 2 2 ( IH* ) , 1 6X , 8HFORECAST , 1 6X , 2 2 ( IH*) / / ) 

9014 FORMAT (28H0SURFACE DENSITY (GM/M**3): ,F8,2) 

9015 FORMAT OHO MET/ 

.48H LEVEL ALTITUDE DIR. SPEED TEMP, 

32H PTEMP DPTEMP PRESS RH/ 

47H NO. (FT) (M) (DEG) (M/S) (KTS) 

33H (DEG. C) (MB.) (%)/ 

.,44(2H— )) 

9016 FORMAT(2XI2,4XI5,2XF6. 1,2XF5. 1,2(1XF5.2) ,3XF5. 1,2XF5.2,2XF4. 1, 
.5XF6.1,4XF4.1,4XA2) 

9017 FORMAT (//20( IF.*) ,8X, 22HMETEOROLOGICAL OPTIONS, 9X, 20 (IH*)/ / 

.43H BOTTOM OF SURFACE LAYER HEIGHT (METERS) : ,9X,F8. 3/ 

,.43H MIXING LAYER HEIGHT (METERS) : ,9X,F8. 3/ 

.42H STND. DEV OF WIND AZIMUTH ANGLE (DEGRS) : , 10X,F8.5) 

9018 FORMAT (/IX, 7 3H ** - INDICATES THAT DATA IS LINEARLY INTERPOLATED FS0901370 

.ROM INPUT METEOROLOGY) S0901380 

9019 FORMAT (67HO*** REEDM ERROR 013, CALCULATION HEIGHT IS ABOVE INPUT S0901390 

*MET. LEVELS) S0901400 

9020 FORMAT(37HO* PROCESSING CONTINUES WITH NEXT RUN/lHl) S0901410 

9021 FORMAT (F6 .0 , 1X,F3 .0, 1X,F3 . 0 ,2F6. 1 ,F7 . 1 , 1X,F3.0) S0901420 

9022 FORMAT (66H0*** REEDM ERROR 014, NO VALID SOUNDING LEVELS WERE FOUNS0901430 

*D ON FILE ,3A2/) S0901440 

9023 FORMAT (49H0*** REEDM WARNING 024, ZERO WIND SPEED AT LEVEL ,12, S0901450 

*27H. PROG. SUBSTITUTES 1.0 M/S/5X,39HDIRECTION NOT MODIFIED MAY BES0901460 


S0901190 

S0901200 

S0901210 

S0901220 

S0901230 

S0901240 

S0901250 

S0901260 

S0901270 

S0901280 

S0901290 

S0901300 

S0901310 

S0901320 

S0901330 

S0901340 

S0901350 

S0901360 


* INCORRECT) 

9024 FORMAT (41H0*** REEDM WARNING 025, EOF READ IN FILE ,3A2, 
*50H, NNNN SHOULD BE LAST IMAGE, DATA MAY BE TRUNCATED) 

-TYPE AND DIMENSION STATEMENTS 

DIMENSION IDCB(272) ,IBUF(40) ,DPTEMP(30) ,LEVELS(30) ,NTEST(5) , 


C 

C- 


S0901470 

S0901480 

S0901490 

S0901500 

S0901510 

S0901520 


*ALTS(100) ,DIRS(100) .SPEEDS(IOO) ,TEMPS(100) .PRESSS(IOO) ,RHS(100) , S0901530 
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I 

I 


*PTEMPS(100) 

EQUIVALENCE (IFRMT,IBUF) , (ALTS ( 1) , PLUS (1) ) , (DIRS(l) ,PLUS(101)) , 
*(SPEEDS(1) ,PLUS(201)) , (TEMPS(l) ,PLUS(301) ) , (PRESSS (1) , PLUS (40 1) ) , 
*(RHS(1) ,PLUS(501)) , (PTEMPS(l) ,PLUS(601)) 


DATA STATEMENTS 

DATA LEVELS/ 30* 2H / 

DATA NTEST/2HTE, 2HTR, 2HMA, 2HAL, 2HSI/ 

DATA MAXHGT/10000.0/,MAXLVS/100/ 

DATA IIHNN/2HNN/ , IIHTE/2HTE/ , IIHRA/2HRA/ , IIHFO/2HFO/ , IIHST/2HST/ , 
*IIH00/2H00/,IIH99/2H99/ 

DATA JVERSN/8213/ 


INITIALIZE I/O DEVICES, COMMON VARIABLES , CONSTANTS 

! ! H.E.C ONLY. 

ONLY USE IF WANT MATERIAL FROM HIGH ALTITUDES WHEN CALCULATING 
DEPOSITION OR CONCENTRATION FROM AL203. 

IF (GRVSET .AND. .NOT. MODELS) MAXHGT = 20000.0 

! ! 

IF (IVERSN .NE. JVERSN) CALL LOADS (-1 , 0 , 0 ,0, 0 , BATCH) 

IFLG=0 

ISNDFO = .FALSE. 

H=0.0 


C 

c SET UP THE FILE NAME FOR THIS RUN AND WRITE OUT THE HEADER 

ISETS = 1 
IWANT =0 
IINFN =0 

C IF MAG. TAPE (TAPE////) 

IF (IPLACE .EQ. 2) GO TO 10 
C DISC FILE 

IF (IPLACE .EQ. 3) GO TO 20 
C SPECIAL DISC FILE (DATA//#) OR TAPE (TAPE////) 


10 lASFN = FILE(3) 

CALL CODE (2) 

READ (IASFN,9004) IINFN 
IWANT = IINFN+RUNNUM 
20 CONTINUE 

IF (IPLACE .EQ. 3.AND.RUNNUM .GT. 1) IWANT = 0 
WRITE (IOU.9006) RUNNUM, (FILE(J) , J=1 , 3) 


C IF THE DATA IS ON A DISK FILE, READ FROM DISK — IF IT 

C IS ON TAPE, READ IT AS KSC 1965 DATA IN SUBROUTINE KSC65 

IFdPLACE .NE. 2)GO TO 30 
CALL KSC65( IWANT, lEOF) 

IF(IEOF) 420,240,170 

C— OPEN THE DATA FILE FOR THIS RUN 


3,0 CALL OPEN (IDCB,IERR, FILE, IB) 
IF(IERR .GT. 0) GO TO 40 
WRITE (lOU, 9008) IERR,FILE 
GO TO 420 


S0901790 

S0901800 

S0901810 

S0901820 

S0901830 

S0901840 

S0901850 

S0901860 

S0901870 

S0901880 

S0901890 

S0901900 

S0901910 

S0901920 

S0901930 

S0901940 

S0901950 

S0901960 

S0901970 

S0901980 

S0901990 

S0902000 

S0902010 

S0902020 

S0902030 

S0902040 

S0902050 
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c 

c 


c 


c 


c 


c 

c 

c 

c 


40 CONTINUE 

read the headings from the data file, setting up the 

APPROPRIATE PARAMETERS 
CALL READF(IDCB,IERR,IBUF,40,LEN) 

IF(IERR .CE. 0)GO TO 60 
50 V;RITE (IOU,9009) IERR,FILE 

IF (.NOT. BATCH) WRITE (1CU,9009) IERR,FILE 
GO TO 420 

60 IF (lUANT .LE. ISETS) GO TO 70 

IF UBUF(l) .NE.IIHNN.OR.IBUF(2) .NE.IIHNN) GO TO 40 
ISETS = ISETS+1 
GO TO 40 

70 IF(IBUF(1) .NE. IIHTE)GO TO 40 
80 WRITE (IOU,9010) (IBUF(I) , 1=1 ,LEN) 

90 CALL READF(IDCB,IERR,IBUF,40,LEN) 

IF(IERR .LT. 0)G0 TO 50 

IFUBUF(l) .NE. IIHRA.AND. IBUF(1) .NE. IIHF0)G0 TO 90 
ISNDFO = .FALSE. 

1F(IBUF(1) .EQ.IIHFO) ISNDFO = .TRUE. 

WRITE (IOU.9010) (IBUF(I) ,I=1,LEN) 

CALL READF ( IDCB , lERR , IBUF , 40 , LEN) 

IF(IERR .LT. 0)G0 TO 50 

WRITE (IOU,9010) (IBUF(I) ,I=1,LEN) 

READ THE SOUNDIMG/FORECAST TIME 

CALL READF(IDCB,IERR,IBUF,9) 

IF(IERR .LT. 0)GO TO 50 
CALL CODE (80) 

READ (IBUF, 9001) ISTIME, ISDAY, ISMON(l) , ISMON(2) , ISYEAR 
CHANGE TO EST OR EDT DEPENDING ON LAUNCH TIME 


S0902060 

S0902070 

S0902080 

S0902090 

S0902100 

S0902110 

S0902120 

S0902130 

S0902140 

S0902150 

S0902160 

S0902170 

S0902180 

S0902190 

S0902200 

S0902210 

S0902220 

S0902230 

S0902240 

S0902250 

S0902260 

S0902270 

S0902280 

S0902290 

S0902300 

S0902310 

S0902320 

S0902330 

S0902340 


ISTIME = ISTIME - 500 

IFdPLACE .EQ. OISTIME = ISTIME - 300 

IFaSDT(2) .NE.IIHST) ISTIME = ISTIME + 100 

IFdSTIME .GT. 0)G0 TO 100 

ISTIME = 2400 + ISTIME 

ISDAY = ISDAY - 1 

WRITE OUT THE NEXT LINE OF THE HEADER 
100 CALL READF(IDCB,IERR,IBUF,40,LEN) 

IFdERR .LT. 0)G0 TO 50 

WRITE (IOU,9010) (IBUF(I) ,I=1,LEN) 

WRITE OUT THE SOUND ING/FORECAST TIME 

WRITE ( I OU , 9 0 1 1 ) ISTIME , LSDT ( 1 ) , LSDT ( 2 ) , I SDAY , ISMON ( 1 ) , I SMON ( 2 ) , 
ISYEAR 

find the FIRST DATA POINT WITH AN ALTITUDE OF 10 FEET 

OR ABOVE. TRY TO FIND A TOTAL OF MAXLEV POINTS WITH ALTITUDES 
BETIJEEN 10 AND MAXHGT FEET INCLUSIVE 
JJ = 0 

DO 230 I=1,MAXLVS 
110 DO 120 K=l,40 
120 IBUF(K) = IBLNK 

CALL READF (IDCB, lERR, IBUF, 40, LEN) 

IF(I .GT. 1) GO TO 130 
IF(IERR .LT. 0) GO TO 50 
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GO TO 140 

130 IFdERR.LT.O .AND. IERR.NE.-12) GO TO 50 
IF(LEN.NE.-l) GO TO 140 
TOITE (IOU,9024) FILE 
IF (.NOT. BATCH) WRITE (ICU,9024) FILE 
GO TO 240 

140 DO 150 K=1,LEN 
KK = K 

IF (IBUF(K) .NE. IBLNK) GO TO 160 
150 CONTINUE 
GO TO 110 
160 CONTINUE 

IF (IBUF(KK) .EQ. IIHNN) GO TO 240 
DO 170 K=l,5 

IF (IBUF(KK) .ME. NTEST(K)) GO TO 170 
IF (K .EQ. 3) JJ = 1 
IF (K .EQ. 5) JJ = 2 
GO TO 110 
170 CONTINUE 

CHECK FOR ALPHA OR NUMERIC FIELDS. 

CALL B2Z(IBUF(L) ,J) 

IF(IBUF(KK).LT.IIHOO.OR. IBUF(KK) . GT. IIH99)GO TO 110 
C READ LEVEL DEPENDING ON TYPE. 

IF (JJ .EQ. 1) GO TO 180 
CALL CODE (80) 

READ (IBUF.9002) ALTS(I) ,DIRS(I) ,SPEEDS(I) ,TEMPS(I) ,PTEMPS(I) , 
PRESSS(I) ,RHS(I) ,DNSTY 

GO TO 190 
180 CONTINUE 

CALL CODE(80) 

READ (IBUF,9021) ALTS(I) ,DIRS(I) ,SPEEDS(I) ,TEMPS(I) .PTEMPS(I) , 
PRESSS(I) ,RHS(I) 

190 CONTINUE 

IF (DIRS(I) .GT. 360.0) GO TO 110 
IF (SPEEDS(I) .GE. 99.0) GO TO 110 
IF (TEMPS(I) .GE. 99.0) GO TO 110 
IF (PTEMPS(I) .GE. 99.0) GO TO 110 
IF (PRESSS(I) .GE. 9999.0) GO TO 110 
IF (RHS(I) .GE. 999.0) GO TO 200 
IF (JJ .NE. 2) GO TO 210 

C CALCULATE RH FOR SIGNIFICANT LEVELS AND MISSING 
200 CALL RELHH(TEMPS(I),PTEMPS(I),PRESSS(I),RHS(I)) 

210 CONTINUE 

IF(ALTS(I).LT. 10.0 .OR. ALTS (I) . GT.MAXHGT) GO TO 110 
IF ( I . EQ . 1 ) SURDEN=DNSTY 
IF(I.EQ.l) SAVEH = ALTS(l) 

IF(I.GT.l .AND. ALTS(I) .LT. SAVEH. AND. JJ.EQ.O) SURDEN=DNSTY 

IF(I.EQ.l) GO TO 230 

J1=I-1 

DO 220 K=1,J1 

IF (ABS (ALTS (I) -ALTS (K) ) - 1 . 0) 110,110,220 
220 CONTINUE 


S0902580 

S0902590 

S0902600 

S0902610 

S0902620 

S0902630 

S0902640 

S0902650 

S0902660 

S0902670 

S0902680 

S0902690 

S0902700 

S0902710 

S0902720 

S0902730 

S0902740 

S0902750 

S0902760 

S0902770 

S0902780 

S0902790 

S0902800 

S0902810 

S0902820 

S0902830 

S0902840 

S0902850 

S0902860 

S0902870 

S0902880 

S0902890 

S0902900 

S0902910 

S0902920 

S0902930 

S0902940 

S0902950 

S0902960 

S0902970 

S0902980 

S0902990 

S0903000 

S0903010 

S0903020 

S0903030 

S0903040 

S0903050 

S0903060 

S0903070 

S0903080 

S0903090 
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c 

c 

c 

c 


230 NUM = I 
GO TO 240 

SORT ALL THE DATA POINTS SO THEY APPEAR IN ASCENDING 
ORDER OF ALTITUDE 
240 NUMl = NUM - 1 

IF(NUMl) 250,290,260 
250 WRITE (I0U.9022) FILE 
GOTO 420 

260 DO 280 1=1, NUMl 
JJ = NUM - I 
DO 270 J=1,JJ 
J1 = J + 1 

IF(ALTS(J) .LE. ALTS(J1))G0 TO 270 
ARG = ALTS(J) 

ALTS(J) = ALTS(Jl) 

ALTS(Jl) = ARG 
ARG = DIRS(J) 

DIRS(J) = DIRS(Jl) 

DIRS(Jl) = ARG 
ARG = SPEEDS (J) 

SPEEDS (J) = SPEEDS (Jl) 

SPEEDS (Jl) = ARG 
ARG = TEMPS (J) 

TEMPS (J) = TEMPS (Jl) 

TEMPS (Jl) = ARG 
ARG = PTEMPS(J) 

PTEMPS(J) = PTEMPS(Jl) 

PTEMPS(Jl) = ARG 
ARG = PRESSS(J) 

PRESSS(J) = PRESSS(Jl) 

PRESSS(Jl) = ARG 
ARG = RHS(J) 

RHS(J) = RHS(Jl) 

RHS(Jl) =■ ARG 
270 CONTINUE 
280 CONTINUE 

CALL ROUTINE INTERP TO SCAN SORTED DATA POINTS AND IF THE DIFFERENCE 
IN ALTITUDE BETWEEN ANY TWO POINTS IS II 1000 FT DO A LINEAR INTERPOL 
ATION TO CREATE INTERMEDIATE LEVELS BETWEEN THE POINTS 
CALL INTRP (LEVELS) 

— ZERO OUT THE REMAINING ELEMENTS OF THE ARRAYS 

290 CONTINUE 
NUMl =NUM 

IF (NUMl .GT. MAXLEV) NUMl = MAXLEV 
DO 300 1=1, NUMl 
ALT(I) = ALTS (I) 

DIR(I) = DIRS(I) 

SPEED(I) = SPEEDS (I) 

TEMP(I) = TEMPS(l) 

PRESS(I) = PRESSS(I) 

PTEMPU) = PTEMPS(I) 

300 RH(I) = RHS(I) 


S0903100 

S0903110 

S0903120 

S0903130 

S0903140 

S0903150 

S0903160 

S0903170 

S0903180 

S0903190 

S0903200 

S0903210 

S0903220 

S0903230 

S0903240 

S0903250 

S0903260 

S0903270 

S0903280 

S0903290 

S0903300 

S0903310 

S0903320 

S0903330 

S0903340 

S0903350 

S0903360 

S0903370 

S0903380 

S0903390 

S0903400 

S0903410 

S0903420 

S0903430 

S0903440 

S0903450 

S0903460 

-S0903470 

S0903480 

S0903490 

S0903500 

S0903510 

S0903520 

S0903530 

S0903540 

S0903550 

S0903560 

S0903570 

S0903580 

S0903590 

S0903600 

S0903610 


I 
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IF (NUMl .GE. MAXLEV) GO TO 320 
NUMl = NUMl+1 
DO 310 I=NUM1, MAXLEV 
ALT(I) = 0.0 
DIR(I) = 0.0 
SPEED(I) =0.0 
TEMP(I) = 0.0 
PRESS(I) = 0.0 
RH(I) =0.0 
310 PTEMP(I) =0.0 
GO TO 330 

320 IF (.NOT. GRVSET. OR. MODELS) GO TO 330 
IF (MAXHGT .LT. 20000.0) GO TO 330 
ALT (NUMl) = ALTS(NUM) 

. DIR(NUMl) = DIRS(NUM) 

SPEED (NUMl) = SPEEDS (NUM) 

TEMP (NUMl) = TEMPS (NUM) 

PRESS (NUMl) = PRESSS(NUM) 

RH(NUMl) = RHS(NUM) 

PTEMP(NUMl) = PTEMPS(NUM) 

330 IF (NUM .GT. MAXLEV) NUM = MAXLEV 
NLAYS = NUM-1 

C CONVERT TO METRIC UNITS 

DO 340 1=1, NUM 

ALT(I) = 0.3048 * ALT(I) 

TEMP(I) = TEMP(I) + 273.16 
SPEED(I) = 0.515 * SPEED(I) 

IF (SPEED(I) .GT. 0.0) GO TO 340 
WRITE (IOU,9023) I 
IF (.NOT. BATCH) WRITE (ICU.9023) I 
SPEED(I) =1.0 
340 CONTINUE 

IF(ICALC.NE.3) GO TO 350 
IF(CALHT.LE.ALT(NUM)) GO TO 350 
WRITE(IOU,9019) 

WRITE(IOU,9020) 

IF (.NOT. BATCH) WRITE (ICU.9020) 

GO TO 420 

C SAVE DEW POINT TEMP AND CALCULATE POTENTIAL TEMPERATURE 

350 DO 360 1=1, NUM 

DPTEMP(I)=PTEMP(I) 

PTEMP(I)=0.0 

PTEMP(I) = POTMP(TEMP(I) ,RH(I) ,PRESS(D) 

360 CONTINUE 

C WRITE THE HEADER FOR SOUNDING OR FORECAST 

IF(ISNDFO) GO TO 370 
WRITE (IOU,9012) 

GO TO 380 

370 WRITE (IOU,9013) 

C WRITE THE SURFACE DENSITY AND ALL THE DATA POINTS 

380 WRITE (IOU,9014) SURDEN 
WRITE (IOU.9015) 


S0903620 
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DO 390 1=1, NUM 

lALTF = 3.281 * ALT(I) + 0.5 

ALTM = ALT (I) 

SPDKNT=SPEED(I)*1. 94175 
APTEMP = PTEMP(I) - 273.16 
TTEMP = TEMP(I) - 273.16 

390 WRITE (IOU.9016) I, lALTF, ALTM, DIR(I) ,SPEED(I) ,SPDKNT, TTEMP, 

APTEMP, DPTEMP( I) ,PRESS(I) ,RH(I) ,LEVELS(I) 

WRITE(IOU,9018) 


C DEFAULT REFERENCE HEIGHT TO BOTTOM LEVEL 

ZRK=ALT(1) 

C DETERJIINE THE DEFAULT VALUE OF SIGMA[R] 


Jl=l 

J2=l 

J3=0 

DO 400 JJ=1,NUM-1 

IF (ABS (PRESS ( JJ) -1000 . ) . LT . ABS (PRESS ( J2) -1000 . ) ) J2=JJ 
IF(ALT(JJ).LE.304.8.AND.ALT(JJ+1).GT.304.8) J3=JJ 
400 CONTINUE 

CALL RSGAZ(J1,J2,J3,SIGMAR) 

410 CONTINUE 
GO TO 430 

C ERROR EXIT. 

420 IFLG=0 

lERROR(l) =1 
17RITE(IOU,9020) 

C CLOSE THE DATA FILE 

430 CALL CLOSE (IDCB) 

NNNEST * 1 
NNNTRY = 2 
CALL REEDM 
END 
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o o 


REEDM SOURCE MODULE &RTIATN 

j 


FTN4 

SUBROUTINE KSC65 (IWANT, lEOF) 

. , UPDATE; 8213 SOURCE: 02 APR 82 


LOCATION: KSC 


C — 
C - 
C - 
C - 
C - 
C — 
Cc 

c**** 


THIS SUBROUTINE READS IN DATA FOR THE REED DIFFUSION 
MODEL FROM MAG TAPE IN KSC 1965 FORMAT 


AREA 


BEGIN COMMON 

04/02/82 

math PARAMETERS AND CONSTANTS 

COI^MON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COID-ION /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMJlV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT , S IGMAR, SIGNER , LSITE , BOTLAY , 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , I VERSN , LOCATN ( 2 ) 

, IPLLNT(4) ,GAFIMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 

FS(20) ,MDLNAM(12) ,DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT .MAXDEP , BATCH , GASSET , GRVSET , 

. MOD EL4, MODELS, MODEL6 

INTEGER RUNNUM , RT , CL , C S 

COMMON /CTRFL/ I FLG, RUNNUM, NUM,NL AYS, NBK,QC,QT, HEAT, ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SiGYNK , 

SIGZ. ISNDFO, CRT, LAYTOP (3) , ITDU, KEEP 
, MIXING, MAXDEP, LAYBOT(3) 

, ALTSV , BATCH , CL ( 14) , CS ( 10) , GASSET , lAGAIN , 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , 

MINUS 1 , MINUS9 , MINS 1 , MINS9 , 

MODEL4 .MODELS ,M0DEL6 .NNNEST , NNNTRY , LLNEST .LLNTRY , 

RT(24) ,TPROPC,lbXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, 

. TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, 

CLRLNE , INSLNE .DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2),' 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , S 1000450 
. CLRLNE, INSLNE, DELINE, SI 000460 

. IESCAJ(3),NULL,IBLNK, S1000470 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S1000480 

C VEHICLE PARAMETERS S 1000490 


SIOOOOOO 
SlOOOOlO 
S1000020 
S1000030 
S1000040 
S1000050 
S1000060 
S1000070 
S1000080 
S 1000090 
****S1000100 
SlOOOllO 
S1000120 
S1000130 
S1000140 
S1000150 
S1000160 
S1000170 
S1000180 
S1000190 

sioooioo 

S1000210 
S1000220 
S1000230 
S1000240 
S1000250 
S1000260 
S1000270 
S1000280 
S1000290 
S1000300 
S1000310 
S1000320 
S1000330 
S1000340 
S1000350 
S1000360 
S1000370 
S1000380 
S1000390 
S1000400 
S1000410 
S1000420 
S1000430 
S1000440 
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COMMON /VCLPR/ VPAR(17) S1000500 

C TIME PARAMETERS SI 0005 10 

COMMON /TIME/ JTIME, JDAY,JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S1000520 

LDAY,LYEAR,ISMON(2) ,JMON(2) ,LMON(2) ,LSDT(2) S1000530 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S1000540 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S1000550 

. RH(30) ,PTEMP{30),SIGEP(30),SIGAP(30) S1000560 

C LAYER PAPJ^IETERS S1000570 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S1000580 

SIGYO(29) S1000590 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) SI 000600 

COMMON /BLAYR/ DIRB (6) , SPEEDB (6) , TEMPB(6) S1000610 

C CALCULATED NEW LAYER PARAMETERS S1D00620 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) , SIGAPN(32) , SIGEPN (32) , S1000630 
SPEEDN(32) S1000640 

C CONVERSION FACTORS S1000650 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S1000660 

C S1000670 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S1000680 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S1000690 

C READ/TOITE BUFFER S 1000700 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S1000710 

0*******:5:*;^^;*t**T»f**;Jr5V***T»::ftr******A****:S:*****:*r** ********** 5 000720 

C S1000730 

C EQUIVALENCE STATEMENTS SI 0007 40 

EQUIVALENCE(IIU,IPAR(1)), (I0U,IPAR(2)), (IPU1,IPAR(3)) S1000750 

,(IPU2,IPAR(4)),(IPU3,IPAR(5)) S1000760 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) S1000770 

C S1000780 

C**** ■ ENDOFCOM MO N AREA ****S1000790 

CC S1000800 

CF -FORMAT STATEMENTS . SI 0008 10 

9001 FORMAT (40A2) S 1000820 

9002 FORMAT (14 , 3X12 , 1XA2 ,A1 , 1X14) S1000830 

9003 FORMAT (F7 . 0 , 3XF3 . 0 ,5XF3 . 0 , 2XF5 . 1 , 3XF5 . 1 ,3XF6. 1 ,2XF3. 0, 10XF6. 1) S1000840 

CF OUTPUT FORMAT STATEMENT SI 000850 

9004 FORMAT ( IHl , 5X, 6HTIME: ,14 , IX, A1 ,A2 ,4X,6HDATE: , 12 , 1X,A2 ,A1 , IX, 14) S1000860 

9005 FORMAT (71 HO*** REEDM ERROR 015, UNEXPECTED END OF FILE OCCURRED ONS 10008 70 

1 SOUNDING FILE ,3A2) S1000880 

9006 FORMAT (4 IHO*** REEDM ERROR 016, SOUNDING DATA FILE ,3A2,33H HAS LES1000890 

ISS. THAN FIVE VALID LEVELS.) S1000900 

C S1000910 

REAL MAXHGT' S1000920 

C DIMENSION STATEMENT SI 000930 

C S1000940 

DIMENSION IBUF(40) ,ALTS(100) ,DIRS(100) ,SPEEDS(100) ,TEMPS(100) , S1000950 

*PRESSS(100) ,RHS(100) ,PTEMPS(100) ,NTEST(7) S1000960 

C S1000970 

EQUIVALENCE (ALTS (1) , PLUS ( 1) ), (DIRS(l) , PLUS (101) ) , S1000980 

*(SPEEDS(1) ,PLUS(201)) , (TEMPS(l) ,PLUS(301)) , (PRESSS(l) ,PLUS(401)) , S1000990 
*(RHS(1),PLUS(501)),(PTEMPS(1),PLUS(601)) SIOOIOOO 

C SlOOlOlO 
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DATA MAXLVS/IOO/.MAXHGT/IOOOO.O/ 

DATA NTEST/2HTE,2HST,2HCA,2HAL,2HOR,2HOO,2H99/ 

C 

C INITIALIZE THE COUNTER FOR THE NUMBER OF SETS OF DATA TO 

C 

ISETS = 0 

IF (GRVSET .AND. .NOT. MODELS) MAXHGT = 20000.0 

C READ DATA FROM TAPE 

10 READ (8»9001) (IBUF(I) ,1=1 ,40) 

C IF AN EOF ON TAPE, SET THE EOF FLAG AND RETITRN 

CALL EXEC(13,8,IEQT5) 

lEOF = IAND(ISHIF(IEQT5,-7) , 1) 

IF(IEOF .EO. 1) GOTO 160 

C- KEEP READING UNTIL THE STANDARD LEVEL DATA IS FOUND 

IF(IBUF(l).NE.NTEST(l).OR.IBUF(2).NE.NTEST(2)) GO TO 10 
ISETS = ISETS+1 

IF (IWANT .GT. ISETS) GO TO 10 


20 READ (8,9001) (IBUF(I) , 1=1 , 40) 

CALL EXEC(13,8,IEQT5) 

lEOF = IAND(ISHIF(IEQT5,-7) , 1) 

IF(IEOF .EO. 1) GOTO 160 

IF(IBUF(1) .NE.NTEST(3) .OR. IBUF(2) . EQ. NTEST(2) )GO TO 20 

C READ THE SOUNDING/FORECAST TIME 

READ (8,9002) ISTIME, ISDAY, ISMON(l) , ISMON(2) , ISYEAR 

CALL EXEC(13,8,IEQT5) 

lEOF = IAND(ISHIF(IEQT5,-7),1) 

IF(IEOF .EQ. 1) GOTO 160 

C CHANGE TO EST OR EDT DEPENDING ON LAUNCH TIME . 

ISTIME = ISTIME - 500 

IF(IPLACE .EQ. 1) ISTIME = ISTIME - 300 
IF(LSDT(2) ,NE. NTEST (2) ) ISTIME = ISTIME + 100 
IFdSTIME .GT. 0)GO TO 30 
ISTIME = 2400 + ISTIME 
ISDAY = ISDAY - 1 

C find THE KEY WORD ALTITUDE (AL) 

30 READ (8,9001) (IBUF(I) ,1=1 ,40) 

CALL EXEC(13,8,IEQT5) 

lEOF = IAND(ISHIF(IEQT5,-7) ,1) 

IF(IEOF .EQ. 1) GOTO 160 
IFdBUF(2) .EQ. NTEST(2))GO TO 20 
IFdBUFd) .NE. NTEST(4))GO TO 30 

C LIMIT DATA TO 100 POINTS — READ THE STANDARD LEVEL DATA 

DO 70 1=1,100 

40 READ(8,9001) (IBUF(J) , J=1 ,40) 

CALL EXEC(13,8,IEQT5) 

lEOF = IAKD(ISHIF(IEQT5,-7) ,1) 

IF(IEOF .EQ. 1) GOTO 160 
CALL B2Z(IBUF(1) , J) 

IF (IBUF(IO) .EQ. NTEST(5)) GO TO 80 
IF (J .GE. NTEST (6). AND. J .LE. NTEST(7)) GO TO 50 
IF (IBUF(l) .EQ. NTEST(l)) GO TO §0 
GO TO 40 
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50 CALL CODE (80) 

READ (IBUF, 9003) ALTS(I) ,DIRS(I) ,SPEEDS(I) ,TEMPS(I) ,PTEMPS(I) , 
IPRESSS(I) ,RHS(1) .SURDN 
IF(DIRS(I) .GT. 360.0) GOTO 40 
IF(DIRS(I) .EQ. 360.0) DIRS(I) = 0.0 
IF(SPEEDS(I) .GE. 99.0) GOTO 40 
IF(TEMPSd) .GE. 99.0) GOTO 40 
IF(PTEMPSd) .GE. 99.0) GOTO 40 
IF(PRESSSd) .GE. 9999.0) GOTO 40 

IF(RHSd) .LE. 0.0 .OR. RHS(I) .GT. 100.0) CALL RELHH(TEMPS(I) , 
1 PTEMPS(I),PRESSS(I),RHS(I)) 

IF(I .EO. USURDEN = SURDN 

IFd.GT. l.AND.ALTSd).LT.ALTS(I-l)) SURDEN=SURDN 
IF (ALTS (I ) .GT. MAXHGT)GO TO 80 
C CHECK FOR DUPLICATE LEVELS. 

IF(I .EQ. 1) GOTO 70 
J = I - 1 
DO 60 K =■ 1,J 

IF(ABS (ALTS (I) -ALTS (K))- 1.0) 40,40,60 
60 CONTINUE 
70 CONTINUE 
80 NUM = I 

IF(NUM .GT. 100)G0 TO 140 

C find THE KEY WORD MANDATORY 

90 IF (IBUF(IO) .EQ. NTEST(5)) GO TO 100 
READ (8,9001) (IBUF(I) , 1=1 , 40) 

CALL EXEC(13,8,IEQT5) 

lEOF = IAND(ISHIF(IEQT5,-7),1) 

IFdEOF .EQ. 1) GOTO 160 

IF(IBUFd) .EQ. NTEST(l) .AND.IBUF(2) .EQ. NTEST(2))G0 TO 150 
IF(IBUF(10).NE.NTEST(5))GO TO 90 

C LIMIT DATA TO 100 POINTS — READ THE MANDATORY LEVEL DATA 

100 DO 130 I=NUM,100 

110 READ(8,9001) (IBUF(J) , J=1 ,40) 

CALL EXEC(13,8,IEQT5) 

lEOF - IAND(ISHIF(IEQT5,-7) ,1) 

IFdEOF .EQ. 1) GOTO 140 
CALL B2Z(IBUF(1) ,J) 

IF (IBUFd).EQ.NTEST(l).OR.IBUF(2).EQ.NTEST(2)) GO TO 140 
IF(J .LT. NTEST(6).OR. J .GT. NTEST(7)) GOTO 110 
CALL CODE (80) 

READ(IBUF,9003) ALTS(I) ,DIRS(I) ,SPEEDS(l) ,TEMPS(I) ,PTEMPS(I) , 
PRESSS(I),RHS(I) 

IF(DIRSd) .GT. 360.0) GOTO 110 
IF(TEMPSd) .GE. 99.0) GOTO 110 
IF(PTEMPSd) .GE. 99.0) GOTO 110 
IF(PRESSS'd) .GE. 9999.0) GOTO 110 

IF(RHSd) .LE. 0.0 .OR. RHS(I) .GT. 100.0) CALL RELHH( TEMPS (I) , 
1 PTEMPS(I),PRESSS(I),RHS(I)) 

IF(DIRSd) .EQ. 360.0)DIRS(I) = 0.0 
IF(ALTSd) .GT. MAXHGT)GO TO 140 
IF(I .LE. 1) GOTO 130 


S1001540 
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mm n i 



n n 


j = I - 1 
DO 120 K = 1,J 

1F(ABS(ALTS(I)-ALTS(K))-1.0) 110,110,120 
120 CONTINUE 
130 CONTINUE 

C NUM IS THE NUMBER OF DATA POINTS 

140 NUM =1-1 

C INCREMENT THE COUNTER — IF THIS IS THE SET OF DATA DESIRED, 

C WRITE OUT THE SOUNDING/FORECAST TIME — OTHERWISE GET THE NEXT 

C SET 

150 IF (IBUF(l).EQ.NTEST(l).OR.IBUF(2).EQ.NTEST(2)) CALL EXEC(3,210B) 

C I7RITE OUT THE SOUNDING/FORECAST TIME 

WRITE (IOU,9004) ISTIME,LSDT(1) ,LSDT(2) ,ISDAY,ISM0N(1) ,ISMON(2) , 
IS YEAR 

THERE MUST BE 5 OR MORE DATA POINTS FOR THIS TO BE A VALID SET 

OF DATA ~ IF THERE IS NOT, RETURN WITH lEOF = -2. 

IF(NUM .GT. 4) GOTO 170 
lEOF = -2 

WRITE(IOU,9006) FILE 
GOTO 170 
160 lEOF = -1 

WRITE(IOU,9005) FILE 
170 RETURN 

C END OF KSC65 

END 
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SUBROUTINE RELHH(T,DP,P,RH) 

. , UPDATE: 8213 SOURCE: 17 FEB 81 LOCATION: KSC 

CALCULATE RELATIVE HUMIDITY 

F(A) = 1013. 25*EXP(A*(13.3185+A*(-1.976+A*(-. 6445-. 1299*A)))) 

Y = 373.16 

IF (P .GT. 0.0) Y = (2326. 853102-55. 974*ALOGT(P))/(9. 238574104- 
. 1. 15*ALOGT(P)) 

X = 1.0-Y/(T+273.16) 

Y = 1.0-Y/(DP+273. 16) 

X = F(X) 

Y = F(Y) 

RH = 100.0*Y/X 

IF (RH .GT. 100.0) RH = 100.0 

RETURN 

END 


SI 100000 
SllOOOlO 
S1100020 
S1100030 
S1100040 
S1100050 
S1100060 
S1100070 
S1100080 
S1100090 
SllOOlOO 
SllOOllO 
S1100120 
S1100130 
S1100140 


m 

w 
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SUBROUTINE B2Z(IA,IB) S1200000 

. , UPDATE: 8213 SOURCE: 06 FEB 81 LOCATION: KSC S 1200010 

C S1200020 

C S1200030 

C - - S1200040 

C - THIS SUBROUTINE CHANGES BLANK FILLED WORDS TO ZEROS. - SI 200050 

C - - S1200060 

C S1200070 

IB = IAND(IA, 177400B) S1200080 

IF(IB .EQ. 020000B)IB = 030000B S1200090 

IC = IAND(IA,000377B) S1200100 

IF(IC .EQ. 000040B)IC = 000060B S1200110 

IB = IOR(IB,IC) S1200120 

'RETURN S1200130 

end S1200140 
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FUNCTION POTMP(TMP,RHM,PRSS) SI 300000 

. , UPDATE: 8213 SOURCE: 06 FEB 81 LOCATION: KSC S1300010 

C S1300020 

C S1300030 

C - - S13000A0 

C - THIS FUNCTION COMPUTES THE POTENTIAL TEMPERATURE GIVEN - S1300050 

C - AMBIENT AIR TEMPERATURE, RELATIVE HUMIDITY, AND THE - SI 300060 

C - ATMOSPHERIC PRESSURE - SI 300070 

C - - S1300080 

C S1300090 

C S1300100 

PT = 1.0-373. 16/TMP S1300110 

PT = 1013. 25*EXP(PT*(13.3185+PT*(-1.976+PT*(-. 6445-. 1299*PT)))) S1300120 

PT = RHM*.01*PT S1300130 

PT = 0.622*PT/(PRSS-PT) S1300140 

PT = TMP*(1.0+1.61*PT)/(1.0+PT) S1300150 

POTMP = PT*(1000.0/PRSS)**0.288 S1300160 

RETURN S 1300170 

END S 1300180 
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INTEGER FUNCTION ISHIF(IVJRD, IPOS) S1400000 

. , UPDATE: 8213 SOURCE: 06 FEB 81 LOCATION: KSC S 1400010 

C S1400020 

C S1400030 

C - - S1400040 

C - THIS FUNCTION SHIFTS BITS IN WORD TWRD BY THE NUMBER OF - S1400050 

C - POSTIONS IN THE VARIABLE IPOS. IF IPOS 0 BITS ARE - S 1400060 

C - SHIFTED TO THE LEFT AND IF IPOS § 0 BITS ARE SHIFTED TO - S1400070 

C - THE RIGHT. BITS SHIFTED OFF EITHER END ARE LOST. ALSO - S 1400080 

C - THE SIGN OF IWRD IS NOT CHANGED. (LEFTMOST BIT = 16) - S1400090 

C - - S1400100 

C S1400110 

C S1400120 

NPOS=IABS(IPOS) S1400130 

DO 10 I=l,NPOS S1400140 

IF(IPOS.LT.O) IWRD=IWRD/2 S1400150 

10 IF(IPOS.GT.O) Iira)=IWRD*2 S1400160 

ISHIF=IURD S1400170 

RETURN S 1400180 

END S1400190 
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SUBROUTINE INTRP(LEVELS) SI 500000 

, , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S1500010 

S1500020 

-S1500030 

THIS ROUTINE CREATES INTERMEDIATE LEVELS OF MET DATA BETWEEN -S1500040 

EXISTING LEVELS OF SPARSE DATA USING SIMPLE LINEAR INTERPOLATION -S 1500050 

-S1500060 

S1500070 

Q S1500080 

Cc S1500090 

C**** BEGIN COMMON AREA ****S1500100 

C 04/02/82 S1500110 

C math parameters and CONSTANTS SI 500 120 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S1500130 

C INPUT OPTIONS S1500140 

REAL LAMBDA S 1500 150 

INTEGER FILE, GOOD, TITLE SI 500 160 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S1500170 

ISHAPE,GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S1500180 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT. S1500190 

IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,BOTLAY, S1500200 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) S1500210 

,RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S1500220 

,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DIS0(10) , S1500230 

TISO(10),TITLE(14),SIGPP(29),SIGLL(29),VS(20), S1500240 

FS(20),MDLNAM(12),DBAR(20) S1500250 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S1500260 

LOGICAL I SNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S1500270 

MODEL4,MODEL5,MODEL6 S1500280 

INTEGER RUNNUM,RT,CL,CS S1500290 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S1500300 

DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S1500310 

SIGZ, ISNDFO, CRT, LAYTOP(3) ,ITDU, KEEP S1500320 

. ,MIXING,MAXDEP,LAYBOT(3) S1500330 

,ALTSV, BATCH, CL(14),CS(10), GASSET, lAGAIN, S1500340 

ICHAR(12),IDXCL,IDXCS,tERROR(5),IFRMT(80), S1500350 

MINUS1,MINUS9,MINS1,MINS9, S1500360 

MODEL4, MODELS, MODEL6,NNNEST.NNNTRY,LLNEST,LLNTRY, S1500370 
RT(24) ,TPROPC,IDXRT S1500380 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S1500390 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S1500400 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S1500410 

CLRLNE,INSLNE, DELINE S1500420 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S1500430 

. INVNDR(2) ,ULINE(2) , S1500440 

TAB , TAB 2 , S ETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , S 1 5 0 0 4 5 0 
. CLRLNE.INSLNE, DELINE, S 1500460 

IESCAJ(3) ,NU1>L,IBLNK, S1500470 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S1500480 

C VEHICLE PARAMETERS S1500490 

COMMON /VCLPR/ VPAR(17) S1500500 
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C TIME PARAMETERS S 15005 10 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S1500520 

. LDAY,LYEAR,ISMON(2) ,JMON(2) ,LMON(2) ,LSDT(2) S1500530 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S1500540 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S1500550 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S1500560 

Q LAYER PARAMETERS S1500570 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S1500580 

SIGYO(29) S1500590 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) SI 500600 

COMMON /BLAYR/ DIRB(6) , SPEEDB (6) ,TEMPB(6) S1500610 

C CALCULATED NEW LAYER PARAMETERS SI 500620 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) .S1500630 
SPEEDN(32) S1500640 

C CONVERSION FACTORS S1500650 

COMMON /CNVRT/ QCONV(4) .QPDEPH S1500660 

Q S1500670 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION**********’^*******S 1500680 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S1500690 

C READ/WRITE BUFFER ' SI 5007 00 

Q A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S1500710 

(,***********************************************************************81500720 
(, S1500730 

C EQUIVALENCE STATEMENTS SI 500740 

EQUIVALENCE(IIU,IPAR(D) , (IOU,IPAR(2)) , (IPU1,IPAR(3)) S1500750 

, (IPU2,IPAR(4)), (IPU3,IPAR(5)) S1500760 

EQUIVALENCE (MAXDEP,GRVSET) , (IFRMT( 1) , IFRMTl) S1500770 

Q S1500780 

C**** END OF COMMON AREA ****81500790 

S1500800 

DIMENSION LEVELS(1),ALTS(100),DIRS(100),SPEEDS(100),TEMPS(100), S1500810 

*PRESSS(100) ,RHS(100) ,PTEMPS(100) S1500820 

(, S1500830 

EQUIVALENCE (ALTS(l) ,PLUS(1)) , (DIRS(l) .PLUS(lOl)) , S1500840 

* (SPEEDS (1) , PLUS (201) ) , (TEMPS ( 1) .PLUS (301)) , (PRESSS(l) ,PLUS(401) ) , SI 500850 
*(RHS(1) ,PLUS(501)), (PTEMPS(1),PLUS(601)) S1500860 

(, S1500870 

DATA MAXLVS/100/ S1500880 

DATA IIHAT/2H**/ S 1500890 

Q S1500900 

DMAX = 1000.0 S1500910 

NLAYS=NUM-1 S 1500920 

j = 0 S1500930 

10 I = I+l S1500940 

IF (I .GT. NLAYS) GO TO 50 S1500950 

IP1=T+1 S1500960 

DIFF = ALTS ( IP 1) -ALTS (I) S1500970 

IF(DIFF.LT.DMAX) GO TO 10 S1500980 

N17LEVS = INT(DIFF/DMAX) S1500990 

NWLAYS = N17LEVS+1 SI 50 1000 

DO 30 J = MAXLVS,IP1,-1 S1501010 

K=J+NWLEVS SI 50 10 20 
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IF(K.LE.MAXLVS) GO TO 20 
GO TO 30 

20 ALTS(K) = ALTS(J) 

DIRS(K) = DIRS(J) 

SPEEDS (K) == SPEEDS (J) 

TEMPS (K) = TEMPS (J) 

PRESSS(K) = PRESSS(J) 

RHS(K) - RHS(J) 

PTEMPS(K) = PTEMPS(J) 

30 CONTINUE 

ALTINC= (ALTS ( IP 1) -ALTS (I) ) /NWLAYS 
SPDINC= ( SPEEDS ( IP 1 ) -SPEEDS ( I) ) /NWLAYS 
TMPINC= (TEMPS (IPl )-TEMPS (I) ) /m^LAYS 
PRSINC= (PRESSS (IP 1 ) -PRESSS (I) ) /Nl^LAYS 
RHINC= ( RHS ( I P 1 ) -RHS ( I ) ) /NWLAY S 
PTPINC= ( PTEMPS (IPl) -PTEMPS ( I) ) /Nl^LAYS 
A1=DIRS(I) 

A2=DIRS(IP1) 

ANGMIN=MIN1(A1 ,A2) 

ANGMAX=MAX1(A1,A2) 

AINC=360 . O-ANGMAX+ANGMIN 
IF ( AINC . LE . 1 8 0 . 0 . AND . A 1 . GT . A2 ) DRINC= AINC 
IF (AINC.LE. 180.0. AND. A1.LE.A2) DRINC=-AINC - 
IF (AINC . GT . 180 . 0 . AND. A1 . GT. A2) DRINC=AINC-360 . 0 
IF(AINC.GT. 180.0. AND. A1.LE.A2) DRINC=360. 0-AINC 

drinc=drinc/ni>;lays 

K=I+N1^EVS 
DO 40 J = IP1,K 
JM1=J-1 

ALTS(J) = ALTS(JM1)+ALTINC 

SPEEDS(J) = SPEEDS (JM1)+SPDINC 

TEMPS (J) = TEMPS (JMD+TMPINC 

PRESSS (J) = PRESSS (JMD+PRSINC 

RHS(J) = RHS(JM1)+RHINC 

PTEMPS (J) = PTEMPS (JMD+PTPINC 

DIRS(J) = DIRS(JM1)+DRINC 

IF(DIRS(J) .GT. 360.0) DIRS(J)=DIRS(J)-360.0 

IF(DIRS(J).LT.0.0) DIRS(J)=360.0+DIRS(J) 

LEVELS (J)=IIHAT 
40 CONTINUE 

NLAYS = NLAYS+NWLEVS 

IF (NLAYS .GT. MAXLVS-1) NLAYS = MAXLVS-1 
I = I+NWLAYS 
GO TO 10 
50 CONTINUE 
NUM=NLAYS+1 

IF (NUM .GT. MAXLVS) NUM = MAXLVS 

RETURN 

END 
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KSC 


THIS SUBROUTINE CALCULATES A SIGMA VALUE GIVEN 
ALTITUDE, SPEED, TEMP, AND PRESSURE FOR THE 
FIRST LEVEL OF DATA, THE lOOOFT LEVEL OF DATA 
AND THE 1000MB LEVEL OF DATA 

IF THESE LEVELS DON'T EXIST DATA IS LINEARLY INTERPOLATED 
TO THESE LEVELS FOR THE CALCULATION OF SIGMA(A) 


SUBROUTINE RSGAZ ( J1 , J2 , J3 , RSIG) 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: 

C 

c 

c - 
c 
c 
c 
c 
c 
c 

c - 

c 

c 

Cc 

c**** BEGIN COMMON ARE 

04/02/82 

MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAI1MAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , I SIG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR , SIGMER, LSITE , BOTLAY , 

ZPvK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) 

, RAI NRT , LAMBDA , TIM 1 , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMIL\P(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS , MODEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , S IGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP (3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT ( 3 ) 

, ALTSV , BATCH , CL ( 1 4 ) , CS ( 1 0) , GASSET , I AGAIN , 

ICHAR( 1 2) , IDXCL , IDXCS , IERROR(5) , IFRMT (80) , 

MINUS 1 ,MINUS9 ,MINS1 ,MINS9 , 

MODEL4 , MODELS , MODEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24) , TPROPC , IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, 

. TAB , TAB 2 , S ETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 

. INVNDR(2) ,ULINE(2) , 


S1600000 
S1600010 
S1600020 
S1600030 
S1600040 
S1600050 
S1600060 
S1600070 
S1600080 
S1600090 
S1600100 
S1600110 
S1600120 
S1600130 
S1600140 
****S16001S0 
S1600160 
S1600170 
S1600180 
S1600190 
S1600200 
S1600210 
S1600220 
S1600230 
S1600240 
S16O02S0 
S1600260 
S1600270 
S1600280 
S1600290 
S1600300 
S1600310 
S1600320 
S1600330 
S1600340 
S16003S0 
S1600360 
S1600370 
S1600380 
S1600390 
S1600400 
S1600410 
S1600420 
S1600430 
S1600440 
S16004S0 
S1600460 
S1600470 
S1600480 
S1600490 


TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , S 1 6O0S00 
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CLRLNE,INSLNE, DELINE, S1600510 


. IESCAJ(3) .NULL.IBLNK, S1600520 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,IN0J,NAMEP(3) S1600530 

C— VEHICLE PARAMETERS S1600540 

COMMON /VCLPR/ VPAR(17) S1600550 

c- time parameters S 1600560 

COMMON /time/ JTIME,JDAY,JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S1600570 

. LDAY,LYEAR,ISMOM(2) ,JMON(2) ,LMON(2) ,LSDT(2) S1600580 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S1600590 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S1600600 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S1600610 

C LAYER PAPJU'IETERS S1600620 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S1600630 

SIGYO{29) S1600640 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) SI 600650 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S1600660 

C CALCULATED NEW LAYER PARAMETERS S 1600670 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S1600680 
SPEEDN(32) S1600690 

C CONVERSION FACTORS SI 600700 

COMMON /CNVRT/ QCONV(4) .QPDEPH S1600710 

C S1600720 


C**********C01!M0N BUFFER ARRAY FOR COMMON MODIFICATION******************S1600730 
COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S1600740 

C READ/WRITE BUFFER S 1600750 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S1600760 


C****************A A*********A****************************************A**s 1600770 


C 

c EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(1)) , (lOU, IPAR(2) ) , (IPU1,IPAR(3)) 

, (IPU2,IPAR(4)) ,(IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP.GRVSET) , ( IFRMT ( 1 ) , IFP^ITl ) 

C 

C**** END OF COMMON AREA 

Cc 

DATA Cl, C2,C3,C4,C5,C6/-0. 008, -.00175,. 0008,. 50864522,. 1132, 
3.8163/ 

DATA C7/.029/ 

C CALCULATION OF SIGAZ 

C NEWTONS METHOD FOR SOLUTION OF F(X,B,D) = 0 

F (X , B ,D) = ( 1 . -X**4) / ( 1 6 . *X*X* (D+C4-2 . *ALOG ( 1 . +X) 

1 - ALOG(l.+X*X)+2.*ATAN(X))**2) - B 
FP(X,D) = (-X**4-l . ) / (8 . *X**3* (D+C4-2 . *ALOG( 1 . +X) 

1 - ALOG(l.+X*X)+2.*ATAN(X))**2) + (1 .-X**4) / (2. * (1 .+X) 

1 *(l.+X*X)*(D+C4-2.*ALOG(l.+X)-ALOG(l.+X*X)+ 

1 2.*ATAN(X))**3) 

C 

c 

c 

RSIG =0.0 

C*** READ 1ST DATA LEVEL 
Z1 = ALT(Jl) 
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VI = SPEED(Jl) 

T1 = TEMP(Jl) 

PZl = PRESS(Jl) 

C*** READ 1000MB DATA LEVEL 

FAC= ( 1000 . 0-PRESS ( J2) ) / (PRESS (J2+1) -PRESS ( J2) ) 

Z2 = ALT(J2)+(FAC*(ALT(J2+1)-ALT(J2))) 

V2 = SPEED(J2)+(FAC*(SPEED(J2+1)-SPEED(J2))) 

T2 = TEMP(J2)+(FAC*(TEMP(J2+1)-TEMP(J2))) 

PZ2 = PRESS(J2)+(FAC*(PRESS(J2+1)-PRESS(J2))) 

C*** READ lOOOFT DATA LEVEL 

^ FAC=(304.8-ALT(J3))/(ALT(J3+1)-ALT(J3)) 

Z3 = ALT(J3)+(FAC*(ALT(J3+1)-ALT(J3))) 

V3 = SPEED(J3)+(FAC*(SPEED(J3+1)-SPEED(J3))) 

T3 = TEMP(J3)+(FAC*(TEMP(J3+1)-TEMP(J3))) 

PZ3 = PRESS(J3)+(FAC*(PRESS(J3+1)-PRESS(J3))) 

IF(IRUN.EQ.4) WRITE(IOU,9001) Z1 ,V1 ,T1 ,PZ1 ,Z2,V2 ,T2 ,PZ2 ,Z3 ,V3 ,T3 
.,PZ3 

9001 F0RMAT(12H DIAGN0STICS/23H SURFACE LEVEL Z,V,T,P=,4F12.5/ 

. 23H 1000 MB LEVEL Z,V,T,P=,4F12.5/ 

23H 1000 FT LEVEL Z,V,T,P=,4F12. 5) 

C ** CONVERT TO PROPER UNITS 
C VI = VI*. 514791 

C V2 = V2*. 514791 

C V3 = V3*. 514791 

C Z1 = Zl*,3048 

C Z2 = Z2*.3048 

C Z3 = Z3*.3048 

C T1 = Tl+273.16 

C T2 = T2+273.16 

C T3 » T3+273.16 

C*** INITIALIZE ZO 
ZO = .20 

C PZl AND PZ3 IN MILLIBARS 
C VI, V2 AND V3 IN METER/SEC 
C Z1.Z2 AND Z3 IN METERS 
C T1,T2 AND T3 IN DEG K 
C ZO IN METERS 

E = 22.9183118 
V=V2 

T=(Tl+T2+T3)/3. 

Z=(Z1*Z2*Z3)**. 33333 

THETAl - T1*((1000./PZ1)**.288) 

THETA2 = T2 

THETA3 = T3*( (1000. /PZ3)**. 288) 

ZA = (Zl+Z2+Z3)/3. 

THETAA = (THETAl + THETA2 + THETA3)/3. 

D = Z/ZO 
ZOZO = ALOG(D) 

DZTIIET = ((Z1-ZA)*(THETA1-THETAA)+(Z2-ZA)*(THETA2-THETAA) 

1 +(Z3-ZA)*(THETA3-THETAA))/((Z1-ZA)**2 + (Z2-ZA)**2 

1 +(Z3-ZA)**2) 

B = 9.8*DZTHET*Z**2/(T*V**2) 
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IF(B) 10,120,40 
10 CONTINUE 
R = 1.5 

U * F(R,B,ZOZO) 

DO 30 I = 1,50 

R1 = R - F(R,B,ZOZO)/FP(R,ZOZO) 

IF(R1 .LE. -1.0) GOTO 220 
U=F(R1,B,ZOZO) 

IF(ABS(R1-R) .LT. l.E-7) GO TO 80 
IF(I.EQ.49) USAV « U 
IF(I.NE.50) GO TO 20 

IF(USAV.LT.O. .AND.U.GT.O. .OR.USAV.GT.O, .AND.U.LT.O.) GO TO 80 
20 CONTINUE 
30 R » R1 
RSIG = 30. 

GO TO 220 . 

40 AP = ZOZO - 1. 

Z00L10=(C6*Z0)/(7.*Z) 

A1 = 7.*SQRT(B)*AP 
A2 = 1. 

A3 = -SQRT(B)*(AP-1.) 

RAD = A2**2 - 4.*A1*A3 
IF(RAD) 50,60,70 
50 CONTINUE 
RSIG =30. 

GO TO 220 

60 REll = -A2/(2.*A1) 

SI = 1. - 7.*RE11**2 
GO TO 130 

70 REl = (-A2 + SQRT(RAD))/(2.*A1) 

RI4 = RE1**2 

ZOOL4 = Z0*RI4/(Z*(1. -7.*RI4)) 

IF(B,LT,C3) GO TO 170 
IF(B.GE.C3) GO TO 190 
80 RIl = (l.-Rl**4)/16. 

ZOOLl = Z0*RI1/Z 

A = ZOZO +C4-2.*ALOG(l.+Rl)-AEOG(l.+Rl**2)+2.*ATAN(Rl) 
IF(B.LT.Cl) GO TO 90 
IF(B.GE.C1.AND.B.LT.C2) GO TO 100 
IF(B.GE.C2) GO TO 110 
90 RSIG = E*2.7/A 
GO TO 220 

100 FB2 - 2.7 + 11?.*(-C1 + B) 

RSIG = E*FB2/A 
GO TO 220 

no FB3 = 3.4 - 725.5*(-C2 +B) 

RSIG = E*FB3/A 
GO TO 220 
120 RI2 - 0 
Z00L2 - 0 

RSIG = 48.816/ZOZO 
GO TO 220 
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Illllllllllllllllll 


130 RI3 = (Sl-l.)/(-7.) 

ZOOL3 = ze*RI3/(Z*(l. -7.*RI3)) 

IF(B.LT.C3) GO TO 140 
IF(B.GE.C3) GO TO 160 
140 FB3 = 3.4 - 725.5*(-C2 + B) 

RSIG - (E*FB3)/( 7.*RI3/( 1. -7,*RI3) + ZOZO ) 

SIGR20= (E*FB3) / (C6+ZOZO) 

IF(RI3.GE.C5) GO TO 150 
GO TO 220 
150 CONTINUE 

RSIG - SIGR20 
GO TO 220 

160 FB4 - 1.55 + 38.04*(B - .0008) 

FB5 = 2.35 + 38.04*(B - .0008) 

RSIG = (E*FB4)/(ZOZ0 -7.*RI3/( 1. -7.*RI3)) 
IF(B.GE.C7)RSIG = (E*FB5) / (ZOZO - 7.*RI3/(1. - 7.*RI3)) . 
SIGR21 = (E*FB4)/(C6+ZOZO) 

SIGR22 - (E*FB5)/(C6+ZOZO) 

IF (RI3 . GE . C5 . AND . B . LT . C7 ) RSIG=SIGR2 1 
IF(RI3.GE.C5.AND.B.GE.C7)RSIG-SIGR22 
GO TO 220 

170 FB3 = 3.4 - 725.5*(-C2+B) 

RSIG - (E*FB3)/( 7.*RI4/(1. - 7.*RI4) + ZOZO) 

SIGR20= (E*FB3) / (C6+ZOZO) 

IF(RI4.GE.C5) GO TO 180 
GO TO 220 
180 CONTINUE 

RSIG = SIGR20 
GO TO 220 

190 FB4 = 1.55 + 38.04*(B - .0008) 

FB5 - 2.35 + 5.43*(B - C7) 

RSIG » (E*FB4)/( 7.*RI4/(1. - 7.*RI4) + ZOZO) 
IF(B.GE.C7)RSIG = (E*FB5) / (ZOZO - 7.*RI4/(1. - 7.*RI4)) 
SIGR21=(E*FB4) / (C6+ZOZO) 

SIGR22. =■ (E*FB5)/(C6+ZOZO) 

IF(RI4.GE.C5.AND.B.LT.C7) GO TO 200 
IF(RI4.GE.C5.AND.B.GE.C7) GO TO 210 
GO TO 220 
200 CONTINUE 

RSIG - SIGR21 
GO TO 220 
210 CONTINUE 

RSIG = SIGR22 
GO TO 220 

C*** CHECK FOR VALID SIGAZ VALUE 
220 CONTINUE 

IF (RSIG.LE.O. .OR. RSIG. GT. 30.) RSIG - 30. 

RETURN 

END 
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oonooooonoooon 


REEDM SOURCE MODULE &RCLDM 


PXNA si 700000 

PROGRAM RCLDM(5) S1700010 . 

. . UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S1700020 

: S1700030 

: S1700040 

c‘. !! ::; S1700050 

Q.y. ::: S1700060 

C::: ORGANIZATION: H. E. CRAMER GO. , ING. ::: S1700070 

::: S1700080 

WORK FOR: DR. J. B. STEPHENS (ES84) ::: S1700090 

::: S1700100 

PROGRAM CODE: RCLDM ::: S1700110 

::: S1700120 

PROGRAM DESCRIPTION: ONE OF THE MODULES FOR ROCKET EXHAUST ::: S1700130 

EFFLUENT DIFFUSION ANALYSIS (MULTI-LAYER)::: S1700140 

::: S1700150 

INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS ::: S! 700160 

::: S1700170 

OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS, PLOTS ::: S1700180 

: : : S1700190 

1 1 ; J t J i 1 1 !! t J ! 5 ^ J • * • J •••••••••••■ • S1700200 

III • I II I II I III :: I :: 1 1 :: 1 1 : X :::::::: I :: I ::::::::: i ::: i : :i :::::: i : : S 17002 10 

S1700220 


Q ***A******^********^************************************************ SI 700230 


C * * S1700240 

C * NASA/MSFC MULTILAYER DIFFUSION MODEL * S1700250 

C * * S1700260 

C * CLOUD RISE PROGRAM — RCLDM * SI 7002 70 

C * * S1700280 

C ******************************************************************** SI 700290 

S1700300 

c**** BEGIN COMMON AREA ****S1700310 

C 04/02/82 S1700320 

C— MATH PARAMETERS AND CONSTANTS S 1700330 

COMMON /MATH/ PI,G,CP,MAXLEV,GA>IMAI,GAMMAC S1700340 

C INPUT OPTIONS S1700350 


REAL LAMBDA SI 700360 

INTEGER FILE, GOOD, TITLE SI 7003 70 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S1700380 

I SHAPE, GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S1700390 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S1700400 

. IPLACE,IPRINT,SIGMAR, SIGNER, LSITE.BOTLAY, S1700410 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) S1700420 

, RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S1700430 

. ,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , S1700440 

TISO(10),TITLE(14),SIGPP(29),SIGLL(29),VS(20), S1700450 

FS(20),MDLNAM(12),DBAR(20) S1700460 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES Si 700470 

LOGICAL I SNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S17004S0 

, MODEL4, MODELS, MODEL6 S1700490 
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INTEGER RUNNUl-l.RT.CL.CS S 1700500 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S1700510 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK, SIGYNK , S 1 700 5 20 

SIGZ, ISNDFO, CRT, LAYTOPO) ,ITDU, KEEP S1700530 

,MIXING,MAXDEP,LAYBOT(3) S 1700540 

,ALTSV, BATCH, CL(14) ,CS(10) , GASSET, lAGAIN, S1700550 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5),IFRMT(80), S1700560 

MINUS 1,MINUS9,MINS1,MINS9, S 1700570 

MODEL4 , MODELS , M0DEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , S 1 7 005 80 
RT(24),TPROPC,IDXRT S1700590 

C- TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. SI 700600 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, SI 7006 10 

> . TAE,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S1700620 

■ , " CLRLNE,INSLNE, DELINE S1700630 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S1700640 

INVNDR(2KULINE(2) , S1700650 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , S 1 7006 60 
CLRLNE,INSLNE, DELINE, ' SI 7006 70 

IESCAJ(3) ,NULL,IBLNK, S1700680 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S1700690 

C VEHICLE PARAMETERS S 1700700 

COMMON /VCLPR/ VPAR(17) S1700710 

C time PARAMETERS S 1700720 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S1700730 

. LDAY,LYEAR,ISM0N(2) ,JMON(2) ,LMON(2) ,LSDT(2) S1700740 

C SOUNDING/ FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S1700750 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S1700760 

. RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S1700770 

C LAYER PARAMETERS S1700780 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S1700790 

. SIGYO(29) S1700800 

C —CALCULATED BOUNDRY DATA (FOR NEW LAYERS) SI 700810 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S1700820 

C CALCULATED NEW LAYER PARAMETERS S1700830 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S1700840 
. SPEEDN(32) S1700850 

C CONVERSION FACTORS S1700860 

COMMON /CNVRT/ QCONV (4) ,QPDEPH S1700870 

C S1700880 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S1700890 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S1700900 

C READ /WRITE BUFFER SI 7009 10 

C —A R R A Y = 2077 + 1 + I + 2 * 900 = 3879S1700920 

C***********************************************************************s 1700930 


C 

C- 


C 

C**A* 

Cc 


EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(1)) , (lOU, IPAR(2) ) , (IPUl , IPAR(3) ) 
, aPU2,IPAR(4)) , (IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP ,GRVSET) , (IFRMT( 1 ) , IFRMTl) 

END OF COMMON AREA 
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NNNEST = 3 
NNNTRY = 1 
CALL REEDM 

C CALCULATE TURBULENCE PARAMETERS 

80 CALL TURB4 

C OUTPUT LAYER PARAMETERS 

WRITE(IOU,9014) 

GO TO (90,100) IPRINT 
90 WRITE(IOU,9002) 

WRITE(IOU,9003) QC,QT,HEAT,AA,BB,CC,CP,DPDZ 
C LAYER PARAMETER OUTPUT 


100 LTIITE(IOU,9004) 

GO TO (110,120) IPRINT 
110 WRITE(IOU,9005) 

GO TO 130 

120 TOITE(IOU,9012) 

130 CONTINUE 

DO 170 I=1,NLAYS 

ISTAR=IBLNK 

IP1=I+1 

T1=FLOAT(INT(TAUK*10.))*. 1 
T2=FLOAT(INT(RISTIM(I)*10.))*. 1 
IF(T1.EQ.T2) ISTAR=IIHBS 
TDX=DX(I) 

TDY=DY(I) 

IF(Q(I) .GT.0.0) GO TO 140 

TDX=0.0 

TDY=0.0 
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140 GO TO (150,160) IPRINT S1702340 

150 WRITE (lOU, 9006) I,ALT(IP1) ,RISTIM(I) ,ISTAR,TDX,TDY,Q(I) S1702350 

. ,SIGLL(I) ,SIGPP(I) ,SIGX0(I) ,SIGYO(I) ,SIGAP(IP1) ,SIGEP(IP1) S1702360 

GO TO 170 S1702370 

160 WRITE(IOU,9013) I,ALT(IP1) ,RISTIM(I) ,ISTAR,TDX,TDY S1702380 

170 CONTINUE S1702390 

IF(IRUN.NE.4) GO TO 180 S1702400 

WRITE (lOU, 90 16) (J,ALT(J) ,DIR(J) ,SPEED(J) ,TEMP(J) ,PTEMP(J) ,PRESS(J) S1702410 
.,RH(J),SIGAP(J),SIGEP(J),J=1,NUM) S1702420 

WRITE(IOU,9017) (J,Q(J) ,SIGXO(J) ,SIGYO(J) ,DX(J) ,DY(J) ,RISTIM(J) , S1702430 

.J=1,NUM-1) S1702440 

9016 FORMAT(//12H DIAGNOSTICS// S1702450 

. ,52H LEVEL, ALT, DIR, SPEED, TEMP, PTEMP, PRESS, RH,SIGAP,SIGEP/ S1702460 

. ,21(I4,1X,9F12.5/)) S1702470 

9017 FORMAT(/33H LAYER, Q, SIGX0,SIGY0,DX,DY,RISTIM/ S1702480 

. ,20(I4,1X,6F12.5/)) S1702490 

180 CONTINUE S1702500 

WRITE (lOU, 90 10) S1702510 

WRITE (lOU, 9007) CALHT,H,TAUK S1702520 

WRITE(IOU,9008) ALT(LAYT0P(1)+1) ,ALT(LAYB0T(1)) S1702530 

IF(11M(2) .NE.0.0) WRITE(IOU,9009) ALT(LAYTOP(2)+l) ,ALT(LAYB0T(2) ) S1702540 

WRITE (lOU, 9011) SIGMAR.SIGMER S1702550 

^ . S1702560 

C COMPUTE LAYER BOUNDARIES PARAMETERS Si 702570 
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INTEGER RUNNU11,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,OC,OT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

SIGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU ,KEEP 
,MIXING,MAXDEP,LAYBOT(3) 

, ALTSV, BATCH, CL(L4) ,CS(10) .GASSET, lAGAIN, 
ICHARdZ) ,IDXCL,IDXCS,TERR0R(5),IFRMT{80), 

MINUS 1,MINUS9, MINS 1,MINS9, 

MODEL4 .MODELS .MODEL6 .NNNEST .NNNTRY .LLNEST .LLNTRY , 
RT(24) .TPROPC.IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET.OFF.BLNKNG.INV.ULINE.INVNDR, 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 
CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2) , 
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TAB , TAB 2 , SETT AB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRD SP.S1700660 


CLRLNE , INSLNE .DELINE , 

IESCAJ(3) .NULL.IBLNK, 

IPAR (5 ) , ICU , lYS J , lYES J , IN J , INOJ .NAMEP (3) 

C VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 

C TIME PARAMETERS 

COMMON /TIME/ JTIME, JDAY, JYEAR.ISTIME.ISDAY.ISYEAR.LTIME, 

LDAY , LYEAR , I SMON ( 2 ) , JMON ( 2 ) , LMON ( 2 ) , LSDT ( 2 ) 

C. SOUNDING /FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) .PRESS(30) , 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) 
g LAYER PARAMETERS 

COIMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , 

SIGYO(29) 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) 

C --CALCULATED NEW LAYER PARAMETERS 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) , S1700840 
. . SPEEDN(32) S1700850 

C CONVERSION FACTORS SI 700860 

COMMON /CNVRT/ QCONV(4) .QPDEPH S1700870 

^ S1700880 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S 1700890 
COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S1700900 

C READ /WRITE BUFFER SI 7009 10 

Q ^ R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S1700920 

-**.*********************************************************************81700930 

^ ✓^1 ^ /^ /\ / r\ 
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C 

c**** 

Cc 


EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(1)) , (lOU, IPAR(2) ) , (IPUl ,IPAR(3)) 
,(IPU2,IPAR(4)) ,(IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP .GRVSET) , (IFRMT(l) .IFRMTl) 

END OF COMMON AREA 
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EQUIVALENCE (AA,VPAR(7)) , (BB,VPAR(8)) , (CC,VPAR(9)) S1701020 

C S1701030 

DATA JVERSN/8213/ S1701040 

DATA IIHBS/2H */ S1701050 

CF FORMAT STATEMENTS. SI 70 1060 

9001 FORMAT (88H0*** REEDM ERROR 017, NOT ENOUGH LAYERS, THE TOP OF THE S1701070 

• LAST LAYER MUST BE GREATER THAli ,F10.5) S1701080 

9002 FORMAT(1X,20(1H*),12X,15HPLLTIE RISE DATA, 13X, 20 (IH*) //) S1701090 

9003 FORMAT (/, IX, 25HEXHAUST RATE OF MATERIAL: , 16X, 1 IH (GRAMS/ SEC) , 9X, S1701100 

.G12.9/1X,22HT0TAL MATERIAL OUTPUT: , 19X, 7H(GRAMS) , 13X,G12. 9 
./ 1X,21HHEAT OUTPUT PER GRAM: ,20X,10H(CALORIES) , 13X,F9.4 
./1X.29HVEHICLE RISE TIME PARAMETERS: , 12X, 15H(TK=(A*Z**B)+C) 

2X,2HA=,8X,F5.4 
59X,2HB=,8X,F5.4 
59X,2HC=,8X,F5.4 


. / 

. / 

. / 1X,21HSPECIFIC HEAT OF AIR: , 20X, 13H(K CAL. /GRAM) , 14X,F5 . 4 
. / 1X,36HVERTICAL GRADIENT OF POTENTIAL TEMP. 

. / 12X,24HTO STABILIZATION HEIGHT: ,6X, 1 OH (DEG. K/M) , 17X.F5.4) 

9004 FORMAT(//1X,20(1H*) ,10X,20H EXHAUST CLOUD , lOX, 20(1H*) //) 

9005 FORMAT ( / 6 2X , 5HLAYER , 8X , 2 (5HCLOUD , 5X) /6X , 4HMET . , 7X , 3HTOP , 7X , 

. 5HCLOUD , 7X , 1 7HRANGE** BEARING , 5X , 6HSOURCE , 8X , 2 (5HHALF- , 5X) /5X , 

.5HLAYER,4X,8HOF LAYER, 3X, 9HRISE TIME, 

. 2 ( 3X , 8HFROM PAD) , 4X , 8HSTRENGTH , 6X , 6HLENGTH , 5X , 5HWIDTH , 5X , 5HS I GXO 
. ,5X,5HSIGYO,5X,5HSIGAP,5X, 

.5HSIGEP/6X,3HNO. ,5X,8H(METERS) ,3X,9H(SECONDS) ,3X,8H (METERS) , 
.3X,8H(METERS) ,5X,7H(GRAMS),5X,4(8H(METERS),2X) ,2(10H(DEGREES) ) 

. /66(2H— )/) 

9006 FORMAT(7X,I2,6X,F6.1,6X,F6. 1,A2,2X,F6.1,5X,F6.1,4X,G10.9,5X,F6.1 
.,4X,F6.1,4X,F6.1,4X,F6.1,4X,F6.l,4X,F6.1) 

9007 FORMAT(//1X,20(1H*) , 10X,20HCLOUD STABILIZATION , 10X,20( IH*) // 

2X,18HCALCULATI0N HEIGHT, 22X,8H (METERS) , 14X,F10. 2 , / 
2X,20HSTABILIZATI0N HEIGHT, 20X,8H(METERS) , 14X, FIO. 2 , / 
2X,18HSTABILIZATI0N TIME, 22X,6H(SECS) , 16X.F10. 2) 


S1701110 
S1701120 
S1701130 
S1701140 
S1701150 
S1701160 
S1701170 
S1701180 
S1701190 
SI 70 1200 
S1701210 
S1701220 
S1701230 
S1701240 
S1701250 
S1701260 
S1701270 
S1701280 
S1701290 
S1701300 
S1701310 
S1701320 
S1701330 
S1701340 


9008 FORMAT(2X,26HFIRST MIXING LAYER HEIGHT: , 14X,8H(METERS) , 11X,5HT0P =S1701350 

. ,F8.2/61X.5HBASE=,F8.2) S1701360 

9009 F0RMAT(2X,29HSEC0ND SELECTED LAYER HEIGHT: , 11X,8H(METERS) , IIX, S1701370 

.5HTOP =,F8.2/61X,5HBASE=,F8.2) S1701380 

9010 FORMAT (/5X, 4 8H * - INDICATES CLOUD STABILIZATION TIME WAS USED/ S1701390 

.5X,50H** - RANGE FROM PAD IS AT CLOUD STABILIZATION TIME/) SI 70 1400 

9011 FORMAT (//2X,25HSIGMAR(AZ) AT THE SURFACE, 16X.9H (DEGREES) , 13X, FIO. 4S1701410 


1/2X,25HSIGMER(EL) AT THE SURFACE, 16X, 9H (DEGREES) , 13X, FIO. 4) 


S1701420 


9012 FORMAT (/59X,7HAZIMUTH, /1 6X,4HMET. ,6X,3HTOP,7X,5HCLOUD,7X,5HRANGE, SI 70 1430 
. ,5X,7HBEARING,/15X,5HLAYER,4X,8HOF LAYER,3X,9HRISE TIME, 

. 2 (3X , 8HFROM P AD ) , / 1 6X , 3HNO . , 5X , 8H (METERS ) , 3X , 9H ( SECONDS ) , 3X , 

. 8H (METERS) , 3X, 8H (METERS) , / lOX, 30 (2H— ) /) 

9013 FORMAT(16X,I2,6X,F6. 1,6X,F6, 1,A2,2X,F6.1,5X,F6.1.5X,F6. 1) 

9014 FORMAT(lHl) 

9015 FORMAT(38HO* PROCESSING CONTINUES WITH NEXT RUN./lHl) 


IF (IVERSN .NE. JVERSN) CALL LOADS(-l ,0,0, 0,0, BATCH) 
CHECK SEGMENT ENTRY POINT. 


S1701440 

S1701450 

S1701460 

S1701470 

S1701480 

S1701490 

S1701500 

S1701510 

S1701520 

S1701530 


F 


iE!;: 


90 



o n n ooo 9 o 9^9 9^9 


c 


IF(MNNTRY .EQ. 3) GOTO 80 S1701540 

INITIAL CONSTANTS AND VARIABLES S1701550 

ZM=0.0 S1701560 

G=9.8 S1701570 

IFLG=0 S1701580 

DPDZ=0.0 S1701590 

COMPUTE BURN PJ^TE FACTOR (RFACT) , SOURCE OUTPUT RATE(QC) , S1701600 


TOTAL OUTPUT STRENGTH (QT) , HEAT OUTPUT(HEAT) AND VEHICLE RISE S1701610 


PARAMETERS ( AA , BB , CC) 

10 RFACT = .001*((1.8*(TPROP-273.16)+32.0)-70.0)+1.0 
20 OC = RFACT*VPAR (NORMAL) 

QT = VPAR(N0RMAL+3) 

HEAT = VPAR(N0RMAL+9) 

CALCULATE PLUME RISE - FOR DELTA LAUNCHES USE AVERAGE OF 

INSTANTANEOUS AND CONTINUOUS PLUME RISE 

INSTANTEOUS PLUME RISE 

30 LTYP = 1 

IF(NORMAL.GT. 1) GO TO 40 
CALL PLUME (LTYP) 

IF(TFLG.GT.O) GO TO 190 
IF(IVHICL.LE.2) GO TO 70 

DELTA LAUNCH - CALCULATE CONTINOUS PLUME RISE FOR AVERAGE 
ZMSV = ZM 
GAMMAX = GAMMAC 
GAMMAY = GAI-IMAC 
GAMMAZ = GAMMAC 

CONTINOUS PLUME RISE 

40 LTYP = 2 

CALL PLUME (LTYP) 

IF(IFLG.GT.O) GO TO 190 
IF(IVHICL.LE.2) GO TO 70 
IF(NORMAL.GT. 1) GO TO 70 
GAMMAX = ,5*(GAMMAI+GAMMAC) 

GAMMAY = GAMMAX 
GAMMAZ = GAMMAX 
ZM = .5*(ZM+ZMSV) 

DO 50 I = 2,NUM 
IF(ALT(I).GE.ZM) GO TO 60 
50 CONTINUE 

60 CALL LEAST ( ALT, PTEMP.DPDZ, I, 0,0. 0,0.0) 

IF(DPDZ.LT.3.322E-4)DPDZ = 3.322E-4 

CALCULATE CLOUD TRAJECTORY AND RISE TIME USING DELXY 

70 CALL DELXY 

CALCULATE SOURCE DISTRIBUTION 

CALL DIST4 

CALCULATE SOURCE DIMENSION 

CALL DIMS4 

IFLG=0 

ALT(1)=0.0 

IF(RUNNUM.GT. 1) GO TO 80 
CALL RDHMM 


S1701620 

S1701630 

S1701640 

S1701650 

S1701660 

S1701670 

S1701680 

S1701690 

S1701700 

S1701710 

S1701720 

S1701730 

S1701740 

S1701750 

S1701760 

S1701770 

S1701780 

S1701790 

S1701800 

S1701810 

S1701820 

S1701830 

S1701840 

S1701850 

S1701860 

S1701870 

S1701880 

S1701890 

S1701900 

S1701910 

S1701920 

S1701930 

S1701940 

S1701950 

S1701960 

S1701970 

S1701980 

S1701990 

S1702000 

S1702010 

S1702020 

S1702030 

S1702040 

S1702050 
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a o 


NNNEST = 3 S1702060 

NMNTRY = 1 SI 702070 

CALL REEDM S1702080 

C CALCULATE TURBULENCE PARAMETERS SI 702090 

80 CALL TURB4 SI 702 100 

C OUTPUT LAYER PARAMETERS SI 702 110 

WRITE(IOU,9014) S1702120 

GO TO (90,100) IPRINT S1702130 

90 WRITE(IOU,9002) S1702140 

WRITE(IOU,9003) QC,QT,HEAT,AA,BB,CC,CP,DPDZ S1702150 

C LAYER PARAMETER OUTPUT SI 702 160 

100 TOITE(IOU,9004) S1702170 

GO TO (110,120) IPRINT S1702180 

110 WRITE(IOU,9005) S1702190 

GO TO 130 S1702200 

120 WRITE (lOU, 90 12) S1702210 

130 CONTINUE S1702220 

DO 170 I=1,NLAYS S1702230 

ISTAR=IBLNK S1702240 

IP1=I+1 S1702250 

Tl=FLOAT(INT(TAUK*10.))*.l S1702260 

T2=FLOAT(INT(RISTIM(I)*10.))*. 1 S1702270 

IF(T1.EQ.T2) ISTAR=IIHBS S1702280 

TDX=DX(I) S1702290 

TDY=DY(I) S1702300 

IF(Qd).GT.O.O) GO TO 140 S1702310 

TDX=0.0 S1702320 

TDY=0.0 S1702330 

140 GO TO (150,160) IPRINT S1702340 

150 WRITE(IOU,9006) I,ALT(IP1) ,RISTIM(I) ,ISTAR,TDX,TDY,Q(I) S1702350 

. ,SIGLL(I) ,SIGPP(I) ,SIGXO(I) ,SIGYO(I) ,SIGAP(IP1) ,SIGEP(IP1) S1702360 

GO TO 170 S1702370 

160 WRITE(IOU,9013) I,ALT(IP1) ,RISTIM(I) ,ISTAR,TDX,TDY S1702380 

170 CONTINUE SI 702390 

IF(IRUN.NE.4) GO TO 180 S1702400 

WRITE(IOU,9016) (J,ALT(J) ,DIR(J) ,SPEED(J) ,TEMP(J) ,PTEMP(J) ,PRESS(J) S1702410 
. ,RH(J) ,SIGAP(J) ,SIGEP(J) ,J=1,NUM) S1702420 

WRITE(IOU,9017)(J,Q(J) ,SIGXO(J),SIGYO(J),DX(J),DY(J) ,RISTIM(J) , S1702430 

.J=1,NUM-1) S1702440 

9016 FORMAT(//12H DIAGNOSTICS// S1702450 

. ,52H LEVEL, ALT, DIR, SPEED, TEMP, PTEMP, PRESS, RH,SIGAP,SIGEP/ S1702460 

. ,21(I4,1X,9F12.5/)) S1702470 

9017 FORMAT(/33H LAYER,Q,SIGXO,SIGYO,DX,DY,RISTIM/ S1702480 

. ,20(I4,1X,6F12.5/)) S1702490 

180 CONTINUE SI 702500 

WRITE (lOU, 90 10) S1702510 

WRITE(IOU,9007) CALHT,H,TAUK S1702520 

WRITE(IOU,9008) ALT(LAYTOP(l)+l) ,ALT(LAYBOT(l)) S1702530 

IF(HM(2).NE.0.0) WRITE (lOU, 9009) ALT(LAYT0P(2)+1) ,ALT(LAYBOT(2) ) S1702540 

WRITE (lOU, 9011) SIGMAR, SIGNER S1702550 

S1702560 

COMPUTE LAYER BOUNDARIES PARAMETERS SI 702570 


92 



o o o 


CALL RRDRM 


190 IF(IFLG) 200,230,210 
200 WRITE (100,9001) ZM 
GOTO 220 

210 WRITE(IOU,9018) IFLG 
9018 FORMAT(59H *** REEDM ERROR 018 
*LS ,12) 

C ERROR EXIT. 

220 lERROR(l) = 1 
WRITE(IOU,9015) 

230 CONTINUE 
NNNEST = 2 
NNNTRY = 5 
CALL REEDM 
END 


S1702580 

S1702590 

S1702600 

S1702610 

S1702620 

S1702630 

S1702640 

S1702650 

(RCLDM) PLUME RISE ERROR FLAG EQUAS1702660 

S1702670 

S1702680 

• S1702690 

S1702700 

S1702710 

S1702720 

S1702730 

S1702740 

S1702750 
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REEDM SOURCE MODULE &RCLDN 


FTN4 

SUBROUTINE PLUME (LTYP) 

, , UPDATE: 8213 SOURCE: 


02 APR 82 LOCATION: KSC 


C - 
C - 
C - 
C - 


THIS SUBROUTINE CALCULATES CLOUD (PLUME) RISE FOR INSTANTANEOUS 
(NOPvMAL) AND CONTINUOUS (ABNORMAL) LAUNCHES 


C 

Cc 

c** 


COMirON AREA 


BEGIN 

04/02/82 

math PARAMETERS AND CONSTAiNTS 

COMMON /MATH/ PI ,G, CP ,MAXLEV, GAMMAI .GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COllMON /INPUT/ IRUN,NUMRUN, MOD EL, IVHICL, NORMAL, TPROP, 

ISHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT , S IGMAR , S IGMER, LSITE , BOTLAY , 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , I VERSN , LOCATN ( 2 ) 

,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 

FS(20) ,MDLNAM(12) ,DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL I SNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS , MODEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT ( 3 ) 

; ALT S V , BATCH , CL ( 1 4 ) , CS ( 1 0 ) , GAS SET , I AGAIN , 

I CHAR ( 1 2) , IDXCL , IDXCS , lERROR (5) , IFRMT ( 80 ) , 

MINUSl ,MINUS9 ,MINS1 ,MINS9 . 

MODEL4 , MODELS , MODEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24),TPROPC,IDXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR , 

TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRD SP , 

CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2) , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP ,51800470 
CLRLNE, INSLNE, DELINE, S 1800480 

IESCAJ(3) ,NULL,IBLNK, S1800490 


S1800010 
S1800020 
S1800030 

- S1800040 

- S18000S0 

- S1800060 

- S1800070 

- S1800080 
S1800090 

S1800100 
S1800110 
****S1800120 
S1800130 
S1800140 
S18001S0 
S1800160 
S1800170 
S1800180 
S1800190 
S1800200 
S1800210 
S1800220 
S1800230 
S1800240 
S18002S0 
S1800260 
S1800270 
S1800280 
S1800290 
S1800300 
S1800310 
S1800320 
S1800330 
S1800340 
S18003S0 
S1800360 
S1800370 
S1800380 
S1800390 
S1800400 
S1800410 
S1800420 
S1800430 
S1800440 
S18004S0 
S1800460 


94 



c 

Q* ii :ff 'k 

cc 


irk'k’k 


END OF COMMON AREA 

RQUIVALE^XE (AA,VPAR(7) ) , (BB ,VPAR(8) ) , (CC,VPAR(9) ) 

ZSUM =0.0 
UBARS =0.0 
IF(LTYP.EQ. 1) GO TO 10 

A1 =°6'!o*QC*HEAT/ (SURDEN*CP*PI*GA1!MAX*GAMMAY) 

B1 = .3333333 
GO TO 20 

10 A1 i^l!o*QC*AA*HEAT/(SURDEN*CP*PI’'XAPIMAX*GAMMAY*GAMM^ 

B1 = 1.0/(4.0-BB) 

20 K = 1 
30 K ® K*** 1 

40 CALL LEAST (ALT, PTEMP.DPDZ.K. 0,0. 0,0.0) 

IF(DPDZ.LT.3.322E-4) DPDZ = 3.322E-4 

mR™ ■ rolRLwmK) -AI.T (K- 1) ) * (SPEEB (K) *SPEED (K-l» *0 . 5 
ZSUM = ZSLH+ALT(K)-ALT(K-1) 

UBARK = UBARS /ZSUM 
CONTINUOUS 

ZM = (A1/(UBARK*DPDZ))**B1 

GO TO 60 

50 ZM = (Al/DPDZ)**B1 

INSTANTANEOUS oc 

ZM = (A1/AA*(AA*ZM**BB+CC) /DPDZ) **0.25 
60 IF(ZM.LE.ALT(K)) GO TO 70 
K = K+1 

IF(K.GT.NUM) GO TO 160 
GO TO 40 

70 IF(ALT(K)-ZM.LE. 10. 0) GO TO 150 
IF(DPDZ-3.322E-4) 80,150,80 
80 CONTINUE 

UBaS^=’ UBARS-^^T (K) -alt (K- 1) ) * (SPEED (K) +SPEED (K-1 ) ) *0 . 5 
ZBARK = ZSUM- (ALT (K) -ALT (K-1)) 

90 ZP = ALT(K) 

100 ZP = ZP-10.0 

^^^^SE^'lp(K)-TPzU?(K)?ZP,PT .PTQlP(K-l) ,ALT(K-1)) 

CALL LEAST (ALT , PTEMP , DPDZ , K- 1 , 1 , ZP , TVP) 

IF(DPDZ.GT.3.322E-4) GO TO 120 
DPDZ = 3.322E-4 
no ZM = ZP 
GO TO 150 

‘ “ UBARZ^ ' SPEED (xt TPZ ( a2t (K) . ZP , SPEED (K) , » 5 W ZP 

uUz - (UBARK.(ZP-ALI(K-l))*(UBARZ^SPEED(K-l))‘0.5)/(ZBARK-ZP 

.-alt(k-D) 


SI8OO8OO 

SI800810 

S1800820 

S1800830 

S1800840 

S1800850 

S1800860 

S1800870 

S1800880 

S1800890 

S1800900 

S1800910 

S1800920 

S1800930 

S1800940 

S1800950 

S1800960 

S1800970 

S1800980 

S1800990 

S1801000 

S1801010 

S1801020 

S1801030 

S1801040 

S1801050 

S1801060 

S1801070 

S1801080 

S1801090 

S1801100 

S1801110 

S1801120 

S1801130 

S1801140 

S1801150 

S1801160 

S1801170 

S1801180 

S1801190 

S1801200 

S1801210 

S1801220 

S1801230 

S1801240 

S1801250 

S1801260 

S1801270 

S1801280 

S1801290 

S1801300 
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ZM = (A17(UBARZ*DPDZ))**B1 
GO TO 140 

130 ZM = (A1/DPDZ)**B1 

ZM = (A1/AA*(AA*ZM**BB+CC)/DPDZ)**.25 
140 IF(ZM.GT.ZP) GO TO 110 

IF(ZM.GT.ZP-IO.O) GO TO 150 
IF(ZP.GE.ALT(K-1)) GO TO 100 
ZM = ALT(K-l) 

C RETURN ZM AND DPDZ 

150 IFLG = 0 

GO TO 180 

C CANNOT CALCULATE ZM AND DPDZ 

160 IFLG = 1 

GO TO 180 
170 IFLG = 2 
180 RETURN 
END 


S1801310 

S1801320 

S1801330 

S1801340 

S1801350 

S1801360 

S1801370 

S1801380 

S1801390 

S1801400 

S1801410 

S1801420 

S1801430 

S1801440 

S1801450 

S1801460 

S1801470 
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o n 


SUBROUTINE DELXY 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 


C 

c 

c - 
c - 
c - 
c - 
c — 
c<p 

c**** 


THIS SUBROUTINE CALCULATES CLOUD TRAJECTORY (DX,DY) AND CLOUD 
RISE TIME TO EACH LEVEL (RISTIM) 


**** 


BEGIN COMMON AREA 

04/02/82 

MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

ISHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA, BETA , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR , SIGMER ,LSITE , BOTLAY , 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) 

, RAINRT , LAMBDA , TIM 1 , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 

FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS ,MODEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /ctrfl/ iflg,runnum,num,nlays,nbk,qc,qt,heat,zm,h, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT ( 3 ) 

,ALTSV,BATCH,CL(14) ,CS(10) .GASSET, lAGAIN, 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , 

MINUSl ,MINUS9 ,MINS1 ,MINS9, 

MODEL4 , MODELS , M0DEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 

RT ( 24) , TPROPC , IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTS ET , OFF , BLNKNG , INV , ULINE , INVNDR , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 
CLRLNE.INSLNE, DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 

INVNDR (2), ULINE (2), 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 
CLRLNE , INSLNE , DELINE, 

IESCAJ(3) ,NULL,IBLNK, 

IPAR(S) , ICU, lYSJ , lYESJ, INJ , INOJ,NAMEP(3) 

VEHICLE PARAMETERS 

CObWON /VCLPR/ VPAR(17) 


S1900000 
SI 9000 10 
S1900020 
■S1900030 
•S1900040 
■S19000S0 
■S1900060 
■S1900070 
-S1900080 
S1900090 
S1900100 
S1900110 
S1900120 
S1900130 
S1900140 
S1900150 
S1900160 
S1900170 
S1900180 
S1900190 
S1900200 
S1900210 
S1900220 
S1900230 
S1900240 
S19002S0 
S1900260 
S1900270 
S1900280 
S1900290 
S1900300 
S1900310 
S1900320 
S1900330 
S1900340 
S19003S0 
S1900360 
S1900370 
S1900380 
S1900390 
S1900400 
S1900410 
S1900420 
S1900430 
S1900440 
S19004S0 
S1900460 
S1900470 
S1900480 
S1900490 
S1900S00 
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c time parameters 

COMMON /TIME/ JTIME. JDAY, JYEAR, ISTIME. ISDAY, ISYEAR.LTIME, S1900520 

* LDAY,LYEAR,ISM0N(2) ,JMON(2) ,LMON(2) ,LSDT(2) SiqnnS'’n 

: sounding/forcast meteorological data (INITIAL LEvks) sJqnnsin 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S1900550 

^ P'H(30),PTEMP(30),SIGEP(30),STGAP(30) Siqnn^fin 

c LAYER PARAMETERS aiyuui&u 

^COMMON /LAYER/ DXX^DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , ^^900580 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) qlqnnAnS 

COmON /BLAYR/ DIRB(6),SPEEDB(6),TEMPB(6) q qnPA?n 

CALCULATED NEW LAYER PARAilETERS cionncon 

^CO^ON /NLYER/ ,BIRN(32) ,DSPEED(32) ,SIGAPH(32) ,SIGEP»(32) ,51900630 

c CONVERSION FACTORS S1900640 

COMMON /CNVRT/ QCONV(4) .QPDEPH cJoonf^n 

Q S1900660 

C*******^*COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************sJ9oo680 

COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) LqoOfiqn 

C READ/limiTE BUFFER S1900690 

— A R R A Y = 2077 + 1 S1900700 

c EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(D), (I0U,IPAR(2)),(IPU1,IPAR(3)) S1900750 

,(IPU2.IPAR(4)).(IPU3.IPAR(5)) 31900760 

^ EQUIVALENCE (MAXDEP.GRVSET), (IFRMT(1),IFRMT1) S1900770 

C**** COMMON AREA ****51900790 


EQUIVALENCE (AA, VPAR(7) ) , (BB, VPAR(8) ) , (CC,VPAR(9) ) 

TT=0.0 

IP=4 

XL=GAMMAZ 

IF(NORMAL.EQ. 1) GO TO 10 
IP=3 
XL=1.0 
10 UF=0.0 
UFS=0.0 
ZF=0.0 
ZFS=0.0 

A1=SURDEN*CP*PI*GAMMAX*GAMMAY*XL/ (3 0*QC*HEAT) 

IF(NORMAL.EQ.l) A1=A1/AA 

B1=G/TEMP(1) 

S=1.0/SQRT(G*DPDZ/TEMP(1)) 

PPI=PI*5.5555555E-3 

TSTR=PI*S 

PPII=1.0/PPI 

DXX=0.0 

DYY=0.0 

1=0 

20 1 = 1+1 


S1900800 

S1900810 

S1900820 

S1900830 

S1900840 

S1900850 

S1900860 

S1900870 

S1900880 

S1900890 

S1900900 

S1900910 

S1900920 

S1900930 

S1900940 

S1900950 

S1900960 

S1900970 

S1900980 

S1900990 

S1901000 

S1901010 

S1901020 
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IF(I.GE.NUM) GO TO 110 

CALL LEAST( ALT , PTEMP , DPDZS , 1+ 1 . 0 . 0 . 0 ,0 . 0) 
IF(DPDZS.LT.3.322E-4) DPDZS=3 . 322E-4 
BK=A1*DPDZS 

IF(NORMAL,GT. 1) GO TO 30 
BK=BK/(ALT(I+1)**BB+CC/AA.) 

GO TO 40 , 

30 UFS=UF+(ALT(I+1)-ALT(I))*(SPEED(I+1)+SPEED(I))*(.5) 

ZFS=ZF+ ( ALT ( 1+ 1) -ALT ( I) ) 

BK=BK*UFS/ZFS 
40 CONTINUE 

ZD=BK*ALT(I+1)**IP 
IF(ZD.GT.2.0) GO TO 80 
thetak=(dir(i+i)+dir(i))*o. 5 

IF(ABS (DIR(I+1)-DIR(I) ) . GT. 180.0) THETAK=THETAK-180. 0 
BBB=1.0-ZD 

IF(BBB.GT. 1.0) BBB=1.0 
IF(BBB.LT.-l.O) BBB=-1.0 
S=1.0/SQRT(B1*DPDZS) 

TK=S*ARCOS (BBB) -TT 
TT=TK+TT 

IF(TT.LE.TSTR) GO TO 50 
TT=TT-TK 
GO TO 80 
50 UF=UFS 
ZF=ZFS 

IF (NORMAL. GT.l) GO TO 60 
RK=0 . 5* ( SPEED ( 1+ 1 ) +SPEED ( I ) ) *TK 
GO TO 70 
60 RK=UF*TK/ZF 
70 BBB=THETAK*PPI 

DY(I)=DY(I-l)-RK*COS(BBB) 

DX(I)=DX(I-1)-RK*SIN(BBB) 

RISTIM(I)=TT 
ILXY=I 
GO TO 20 

80 RK=(ZM-ALT(I))/(ALT(I+1)-ALT(I))*.5*(SPEED(I+1)-SPEED(D) 

+SPEED(I) 

IF(NORMAL.EQ. 1) GO TO 90 
RK=RK* ( ZM- ALT ( I ) ) +UF 
ZF=ZF+(ZM-ALT(I)) 

RK=RK/ZF 

90 RK=RK* (TSTR-TT) 

BBB= (DIR(I+1)-DIR(I)) 

IFCBBB.GT. 180.0) BBB=BBB-360 . 0 
IF(BBB.LT. -180.0) BBB=BBB+360 . 0 
BBB=AMOD (BBB, 360.0) 

THETAM=BBB/(ALT(I+1)-ALT(I))*(ZM-ALT(I))+DIR(I) 

THETAK=.5*(THETAM+DIR(D) 

IF(ABS(THETAM-DIR(I)) .GT. 180.0) THETAK=THETAK-180.0 

BBB=T1IETAK*PPI 

DX(I)=DX(I-1)-RK*SIN(BBB) 


S1901030 

S1901040 

S1901050 

S1901060 

S1901070 

S1901080 

S1901090 

S1901100 

S1901110 

S1901120 

S1901130 

S1901140 

S1901150 

S1901160 

S1901170 

S1901180 

S1901190 

S1901200 

S1901210 

S1901220 

S1901230 

S1901240 

S1901250 

S1901260 

S1901270 

S1901280 

S1901290 

S1901300 

S1901310 

S1901320 

S1901330 

S1901340 

S1901350 

S1901360 

S1901370 

S1901380 

S1901390 

S1901400 

S1901410 

S1901420 

S1901430 

S1901440 

S1901450 

S1901460 

S1901470 

S1901480 

S1901490 

S1901500 

S1901510 

S1901520 

S1901530 

S1901540 
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DY(I)=DY(I-1)-RK*C0S(BBB) 

RISTIM(I)=TSTR 
ILXY=I 
100 1 = 1+1 

IF(I.GE.NUM) GO TO 110 

RK=TSTR* . 5* (SPEED (I+l ) +SPEED (I) ) 

ZF=(DIR(I+1)+DIR(I))*.5 

IF(ABS(DIR(I+1)-DIR(I)).GT. 180) ZF=ZF-180.0 

BBB=ZF*PPI 

DX(I)=-RK*SIN(BBB) 

DY(I)=-RK*C0S(BBB) 

RISTIM(I)=TSTR 
GO TO 100 
110 CONTINUE 
I=NUM-1 
DO 140 J=1,I 

IF(DX(J) .EQ.O.O .AND. DY(J) . EQ. 0. 0) GO TO 140 
TT = 0.5*(SPEED(J+1)+SPEED(J))*(TSTR-RISTIM(J)) 

BBB = 0.5*(DIR(J+1)+DIR(J)) 

IF (ABS(DIR(J+1)-DIR(J)) .GT. 180.0) BBB = BBB-180 0 
BBB = (BBB+180.0)*PPI 
UF = DX(J)+TT*SIN(BBB) 

ZF = DY(J)+TT*COS(BBB) 

BBB=270. 0-ATAN2 (ZF, UF) *PPII 
IF(BBB.GT. 360.0) BBB=BBB-360. 0 
IF(BBB.GT. 180. 0) GO TO 120 
BBB=BBB+180.0 
GO TO 130 
120 BBB=BBB-180.0 
130 DX(J) = SQRT(UF*UF+ZF*ZF) 

DY(J)=BBB 
140 CONTINUE 
RETURN 
END 


S1901550 

S1901560 

S1901570 

S1901580 

S1901590 

S1901600 

S1901610 

S1901620 

S1901630 

S1901640 

S1901650 

S1901660 

S1901670 

S1901680 

S1901690 

S1901700 

S1901710 

S1901720 

S1901730 

S1901740 

S1901750 

S1901760 

S1901770 

S1901780 

S1901790 

S1901800 

S1901810 

S1901820 

S1901830 

S1901840 

S1901850 

S1901860 

S1901870 

S1901880 
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SUBROUTINE TURB4 
, , UPDATE: 8213 


SOURCE: 02 APR 82 LOCATION: KSC 


I THIS SUBROUTINE CALCULATES THE STANDARD DEVIATION OF THE WIND 
- AZIMUTH AND WIND ELEVATION ANGLES 


C 

**** 


BEGIN COMMON AREA 


04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

input OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, I VHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BET A , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR , SIGNER , LSITE , BOTLAY , 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 

,IPLLNtU) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DIS0(10) , 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 

FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS , MODELS 

INTEGER RUNNUM,RT, CL, CS ^ u ’ 

COMMON /CTRFL / IFLG , RUNNUM , NTJM , NLAY S , NBK , QC , QT , HEAT , ZM , H , 

COMMON /Gil ppj52;tauk,surden,zrl,ibot,itop,sigxnk.sigynk, 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP ,LAYBOT ( 3 ) 

, ALTSV , BATCH , CL ( 14 ) , CS ( 10) , GASSET , I AGAIN , 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , 

MINUS 1 ,MINUS9 ,MINS1 ,MINS9, 

MODEL4 , MODELS , MODELS , NNNEST , NNNTRY , LLNEST , LLNTRY , 

RT(24) ,TPROPC,IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,0FF,BLNKNG,INV,ULINE,INVNDR, 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN, CURLFT. CLRDSP , 

CLRLNE.INSLNE, DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 

TAb!tAB21 sStAB ! C^TAB , CURSUP , CURSDN , CURLFT , CLRDSP , ^2000450 
CLRLNE.INSLNE, DELINE, 
lESCAJO) ,NULL,IBLNK, 

IPAR(S),ICU,IYSJ,IYESJ,INJ,INOJ.NAMEP(3) S2000490 

VEHICLE PARAMETERS coonnson 

COMMON /VCLPR/ VPAR(17) biUUU:)UU 


S2000000 
S2000010 
S2000020 
S2000030 

- S2000040 

- S20000S0 

- S2000060 

- S2000070 
S2000080 

S2000090 
****S2000100 
S2000110 
S2000120 
S2000130 
S2000140 
S20001S0 
S20001S0 
S2000170 
S2000180 
■ S2000190 
S2000200 
S2000210 
S2000220 
S2000230 
S2000240 
S20002S0 
S20002S0 
S2000270 
S2000280 
S2000290 
S2000300 
S2000310 
S2000320 
S2000330 
S2000340 
S20003S0 
S20003S0 
S2000370 
S2000380 
S2000390 
S2000400 
S2000410 
S2000420 
S2000430 
S2000440 
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S2000510 
S2000520 
S2000530 
S2000540 
S2000550 
S2000560 
S2000570 
S2000580 
S2000590 
S2000600 
S2000610 
S2000620 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,32000630 



SPEEDN(32) 

S2000640 

C- 

CONVERSION FACTORS 

S2000650 


COMMON /CNVRT/ QC0NV(4) ,QPDEPH 

S2000660 

G 


S2000670 

C**********C0MM0M BUFFER ARRAY FOR COMMON MODIFICATION******************S2000680 


COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) 

S2000690 

C- 

READ/WRITE BUFFER 

S2000700 

C- 

A R R A Y = 2077 +1 + 1 + 2 * 900 

- 3879S2000710 




S2000730 

c- 

EQUIVALENCE STATEMENTS 

S2000740 


EQUIVALENCE(IIU,IPAR(1)),(I0U,IPAR(2)),(IPU1,IPAR(3)) 

S2000750 


, (IPU2 , IPAR(4) ) , (IPU3 , IPAR(5) ) 

S2000760 


EQUIVALENCE (MAXDEP,GRVSETK (IFRMT(l) ,IFRMT1) 

S2000770 

C 


S2000780 

C**** END OF COMMON AREA 

****52000790 

c<; 


S2000800 

c 


S2000810 


PHIl = G*DPD2/TEMP(1) 

S2000820 


TAUK = PI/SQRT(PHI1) 

S2000830 


IF(TAUK.GT. 600.0 .OR. TAUK. LE. 0.0) TAUK = 600.0 

S2000840 


K = 0 

S2000850 


IFdSIG.EQ. 1) GO TO 40 

S2000860 


10 K = K+1 

S2000870 


IF(K.GT.NUM) GO TO 40 

S2000880 


IF(ALT(K).EQ.HM(D) GO TO 20 

S2000890 


IF(ALT(K).GT.HM(D) GO TO 30 

S2000900 


SIGAP(K) = .5*SIGMAR 

S2000910 


SIGEP(K) = .5*SIGMER 

S2000920 


GO TO 10 

S2000930 


20 SIGAP(K)=SIGMAR*. 37037037 

S2000940 


SIGEP(K)=SIGMER*. 37037037 

S2000950 


GO TO 10 

S2000960 


30 SIGAP(K) =1.0 

S2000970 


SIGEP(K) =1.0 

S2000980 


GO TO 10 

S2000990 


40 RETURN 

S2001000 


END 

S2001010 


C TIME PARAMETERS 

COMMON /TIME/ JTIME, JDAY, JYEAR.ISTIME, ISDAY.ISYEAR.LTIME, 
LDAY,LYEAR,ISMON(2) ,JMON(2) ,LMON(2) ,LSDT(2) 

C SOUNDING/ FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , 
RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) 
c layer PARAMETERS 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,0(29) ,RISTIM(29) ,SIGXO(29) , 
. SIGYO(29) 

C CALCULATED BOUND RY DATA (FOR NEW LAYERS) 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) 

C CALCULATED NEW LAYER PARAMETERS 
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SUBROUTINE DIST4 

UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC^ 

THIS SUBROUTINE DETERMINES THE DISTRIBUTION OF MATERIAL IN EACH 
LAYER DEPENDING ON THE SHAPE OF THE SOURCE CLOUD 


S2100000 
S2100010 
-S2100020 
-S2100030 
-S2100040 
-S2100050 
-S2100060 
— S2100070 


C 

'k'k'k'k 


BEGIN COMMON AREA 


0^^102182 

math PARAMETERS AND CONSTANTS 

COMMON /math/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN.NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BET A , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT , S IGMAR , SIGMER, LSITE , BOTLAY , 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) 

, RAINRT , LAMBDA , TIM 1 , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

--COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS ,MODEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS ,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

SIGZ , ISNDFO , CRT ,LAYTOP (3) . ITDU ,KEEP 
.MIXING ,MAXDEP ,LAYBOT(3) 

,ALTSV, BATCH, CL(14) ,CS(10) .GASSET, lAGAIN, 
ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFR>IT(80) , 

MINUS 1 ,MINUS9 , MINS 1 .MINS9 , 

MODEL4 ,M0DEL5 ,M0DEL6 .NNNEST .NNNTRY .LLNEST.LLNTRY , 
RT(24) ,TPROPC,IDXRT 

terminal CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS, 

INTEGER ALTSET,0FF,BLNKNG,INV,ULINE,INVNDR, 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 
CLRLNE,INSLNE, DELINE /o\ 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2), 


S2100080 
****S2100090 
S2100100 
S2100110 
S2100120 
S2100130 
S2100140 
S2100150 
S2100160 
S2100170 
S2100180 
S2100190 
S2100200 
S2100210 
S2100220 
S2100230 
S2100240 
S2100250 
S2100260 
S2100270 
S2100280 
S2100290 
S2100300 
S2100310 
S2100320 
S2100330 
S2100340 
S2100350 
S2100360 
S2100370 
S2100380 
S2100390 
S2100400 
S2100410 
S2100420 
S2100430 


SB:iAB2:sm«;c[RTAB.CURSl>P 


CLRLNE , INSLNE , DELINE , 
IESCAJ(3),NULL,IBLNK, 

I IPAR(5) , ICU , lYSJ, lYESJ, INJ, INOJ.NAMEP (3) 

VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 

time parameters 


S2100450 
S2100460 
S2100470 
S2 100480 
S2100490 
S2100500 
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COIMON /TIME/ JTIME,JDAY,JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S2100510 

LDAY,LYEAR,ISMON(2),JMON(2) ,LMON(2),LSDT(2) S2100520 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S2 100530 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S2100540 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S2100550 

C LAYER PARAMETERS S2 100560 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S2100570 

SIGYO(29) S2100580 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S2 100590 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S2100600 

C : CALCULATED NEW LAYER PARAMETERS S2 100610 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) , SIGAPN(32) , SIGEPN(32) , S2100620 
SPEEDN(32) S2100630 

C CONVERSION FACTORS S2 100640 


COMMON /CNVRT/ QCONV(4) jQPDEPH S2100650 

S2100660 


C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S2 100670 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S2100680 

C READ/WRITE BUFFER S2 100690 

C A R R A Y = 2077 + 1 + 1 . + 2 * 900 = 3879S2100700 

C***********************************************************************g2 1007 10 


C EQUIVALENCE STATEMENTS 

EQUIVALENCE ( I lU , IPAR ( 1 ) ) , (lOU , IPAR ( 2) ) , ( IPUl , IPAR ( 3 ) ) 

, (IPU2 , IPAR(4) ) , (IPU3 ,IPAR(5) ) 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) ,IFRMT1) 

C 

c**** END OF COMMON AREA 

CC 

EQUIVALENCE (AA, VPAR(7) ) , (BB,VPAR(8) ) , (CC,VPAR(9)) 

DOUBLE PRECISION DO ,D1 ,D2 ,D3 ,D4 ,D5 ,D6 

DATA Dl/4.9867347D-2/,D2/2. 11410061D-2/,D3/3.2776263D-3/ 

DATA D4/3.80036D-5/, D5/4 . 88906D-5/ , D6/5.383D-6/ 

IF (NORMAL. GT. 1) GO TO 10 
QQ = QC*(AA*ZM**BB+CC) 

GO TO 20 
10 QQ = QT 

20 IF(ISHAPE.EQ.2) GO TO 30 

SQ2I = 1.0/(GAMMAZ*ZM*. 465 116279) 

PHI =0.0 
GO TO 40 

30 SQ2I = 0.75/(GAMMAZ*ZM) 

PHI = 1.0/(3.0*(GAMMAZ*ZM)**2) 

ZTC = ZM*(1.0+GAMMAZ) 

ZBC = ZM*(1.0-GAMMAZ) 

40 K = 1 
50 K = K+1 

IF(ISHAPE.EQ.2) GO TO 100 
IFLG = 0 

ZP = (ALT(K)-ZM)*SQ2I 
IF (ZP) 70,60,80 
60 PZ = .5 


S2100720 

S2100730 

S2100740 

S2100750 

S2100760 

S2100770 

****S2100780 

S2100790 

S2100800 

S2100810 

S2100820 

S2100830 

S2100840 

S2100850 

S2100860 

S2100870 

S2100880 

S2100890 

S2100900 

S2100910 

S2100920 

S2100930 

S2100940 

S2100950 

S2100960 

S2100970 

S2100980 

S2100990 

S2101000 

S2101010 

S2101020 
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GO TO 90 
70 ZP = -ZP 

80 D0^= i.0-0.5M1.0+ZP*(Dl+ZP*(D2+ZP*(D3+ZP*(D4+ZP*(D5 
. (-16) 

PZ = DO 

IF(IFLG.EQ.l) PZ = 1.0-PZ 
90 PZP = PZ-PHI 

GO TO no 

100 PZP =0.0 
ZT = ALT(K) 

ZB = ALT(K-l) 

IF(ZB.GT.ZTC .OR. ZT.LT.ZBC) GO TO 110 
IF(ZT.GT.ZTC) ZT = ZTC 
IF(ZB.LT.ZBC) ZB = ZBC 

P2P = SQ2I* ( (ZT-ZB) — ( (ZT-ZM) **3- (ZB— ZM) **3) '“PHI) 

110 Q(K-l) = PZP*QQ 

1F(Q(K-1) .LT. 0.0) Q(K-l) =0.0 

IF(ISHAPE.EQ. 1 .AND. Q (K-1) . LT. 1 . OE-20) QQ 0.0 

IF(ISHAPE.EQ. 1) PHI = PZ 

IF(K.LT.NITM) GO TO 50 

IF (NORMAL. GT. 1) GO TO 140 

K=2 


ZP=ZM 

120 IF(ALT(K) .GE.ZM) GO TO 130 
K=K+1 

IF(K.LE.NUM) GO TO 120 
GO TO 140 

130 IF(K.GT.NUM) GO TO 140 , 

Q(K-l) = QC*AA*(ALT(K)**BB-ZP**BB)+Q(K-1) 

ZP = ALT(K) 


K = K+1 
GO TO 130 
140 CONTINUE 
RETURN 
END 


S2101030 

S2101040 

S2101050 

+ZP*D6))))))**S2101060 

S2101070 

S2101080 

S2101090 

S2101100 

S210U10 

S2101120 

S2101130 

S2101140 

S2101150 

S2101160 

S2101170 

S2101180 

S2101190 

S2101200 

S2101210 

S2101220 

S2101230 

S2101240 

S2101250 

S2101260 

S2101270 

S2101280 

S2101290 

S2101300 

S2101310 

S2101320 

S2101330 

S2101340 

S2101350 

S2101360 

S2101370 

S2101380 
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SUBROUTINE DIMS4 

^ ’ UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S2200010 

C - S2200020 

^ dimensions AT EACH LAYER :luZll 


(H) 


AREA 


C - AND THE CLOUD RISE HEIGHT 
C - 

C 

Cc 

^**** BEGIN COMMON 

04/02/82 

MATH PARAMETERS AND CONSTANTS 
COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN.NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

ISHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , IS IG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR, SIGNER, LSITE , BOTLAY 
ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE ( 3 ) ’ 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 

,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DISO(10) 

TISO(IO) ,TITLE(14),SIGPP(29),SIGLL(29),VS(20) ,’ 

FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS .FLAGS .GENERAL AND INDEX VARIABLES 
LOGICAL I SNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET 
. MODEL4, MODELS, MODEL6 

INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT ZM H 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , S IGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT (3 ) 

, ALTSV , BATCH , CL { 1 4 ) , CS ( 1 0) , GASSET , I AGAIN , 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5),IFRMT(80) 
MINUS1,MINUS9,MINS1,MINS9, 

M0DEL4 , MODELS , MODELS , NNNEST , NNNTRY , LLNEST . LLNTRY 
RT(24) ,TPR0PC,IDXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS 

INTEGER ALTSET,0FF,BLNKNG.INV,ULINE,INVNDR, ^^MBERS. 

. TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP 

. CLRLNE,INSLNE, DELINE ’ 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHFf2) 
INVNDR(2),ULINE(2), ’ 

TAB , TAB 2 , S ETTAB , CLRTAB , CURS UP , CURSDN , CURLFT , CLRDSP, S2200440 
CLRLNE,INSLNE, DELINE, 

IESCAJ(3),NULL,IBLNK, . S2200460 

c : VEHICLE S2200470 

COMMON /VCLPR/ VPAR(17) 

c time parameters 


-S22000SO 

-S2200060 

S2200070 

S2200080 
****82200090 
S2200100 
S2200110 
S2200120 
S2200130 
S2200140 
S22001S0 
S2200160 
S2200170 
S2200180 
S2200190 
S2200200 
S2200210 
S2200220 
S2200230 
S2200240 
S22002SO 
S2200260 
S2200270 
S2200280 
S2200290 
S2200300 
S2200310 
S2200320 
S2200330 
S2200340 
S22003S0 
S2200360 
S2200370 
S2200380 
S2200390 
S2200400 
S2200410 
S2200420 
S2200430 
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COMMON /TIME/ JTIME, JDAY. JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S2200510 

LDAY,LYEAR,ISMON(2) , JMON(2) ,LMON(2) ,LSDT(2) S2200520 

C 1 SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S2200530 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S2200540 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S2200550 

C LAYER PARAMETERS ^ 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S22005/0 

SIGYO(29) S2200580 

C CALCULATED BO.UNDRY DATA (FOR NEW LAYERS) S2200590 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S2200600 

C CALCULATED NEW LAYER PARAMETERS S2200610 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) .S2200620 
SPEEDN(32) S2200630 

C — CONVERSION FACTORS S2200640 

COMMON /CNVRT/ QCONV(4) ,QPDEPH 

^ S2200660 

C**********COMMON BUFFER ARPJ^Y FOR CO>MON MODIFICATION******************S2200670 
COMMON /EXTRA/ NCOM(l), NTOTAL(l) , PLUS(900) S2200680 

C READ/WRITE BUFFER 

R R A Y = 2077 + 1 1 + 2 * 900 “ 3879S2200/00 

r***********************************************************************^^^®*^^^° 
^ S2200720 

C EQUIVALENCE STATEMENTS S2200730 

EQUIVALENCE(IIU,IPAR(D) , (IOU,IPAR(2)) , (IPUl , IPAR(3) ) S2200740 

. , hPU2,IPAR(4)) , (IPU3,IPAR(5)) S2200750 

EQUIVALENCE (MAXDEP ,GRVSET) , (IFRMT(l) ,IFRMT1) 

C**** END OF COMMON AREA ****S2200780 

J: S2200790 

S2200800 

a=gammax*zm I 2200820 

B=GAMMAY*ZM S2200820 

C=GAMMAZ*ZM S2200840 

CINV=1.0/C S2200840 

ZTC=ZM+C S2200850 

ZBC-ZH-C S2200860 

V ■> miM S2200870 

2? - aS K-n S2200880 

ZT-ALtV) ’ S2200890 

TWV in 21 7B-0 0 S2200900 

S2200910 

sLio’o S2200920 

SYO-olo S2200930 

IF(ZB.GT.ZTC.OR.ZT.LT.ZBC) GO TO 20 coonno^n 

IF(ZT.GT.ZTC) ZT=ZTC coonnQAO 

IF(ZB.LT.ZBC) ZB=ZBC S22009bU 

ZO=ABS(ZP-ZM) 

ZTEST=ZO*CINV |2200980 

IF(ZTEST.LT.l.O) GO TO 10 ooomnnn 

ZP= 5*(ZT+ZB) S2ZU1UUU 

7n-ARc;J7P 7M S2201010 

ZO=ABS(ZP-ZM) C79mn9n 

10 FAC=(l-(ZO*ZO)*(CINV*CINV)) S2..U1U.U 
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FAC=FAC**,5 
SXO = A* FAC 
SYO = B*FAC 

20 IFdSHAPE .EQ. 2 .OR, SXO .GT. 0.0 
SXO =50.0 
SYO = 50.0 

30 IF (NORMAL, GT.l) GO TO 40 
IF(ZP.LE.ZM) GO TO 40 
IF(SXO.LT.199.95) 8X0=199.95 
IF(SYO.LT. 199.95) SYO=199.95 
40 SIGLL(K-l) = SXO 
SIGPP(K-l) = SYO 
SIGXO(K-l)=SXO*. 465 116279 
SIGY0(K-1)=SY0*. 465116279 
50 CONTINUE 
H = ZM 
RETURN 
END 


S2201030 

S2201040 

S2201050 

.OR. ZP .GE. ZM) GOTO 30 S2201060 

S2201070 

S2201080 

S2201090 

S2201100 

S2201110 

S2201120 

S2201130 

S2201140 

S2201150 

S2201160 

S2201170 

S2201180 

S2201190 

S2201200 
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c 


SUBROUTINE LEAST(ALT,PTEMP,DPDZ,K,ISW,ZP,TVP) 

, UPDATE: 8213 SOURCE: 06 FEB 81 LOCATION: 

DIMENSION ALT ( 1 ) , PTEMP ( 1 ) 

IF(K.LE.l) GO TO 50 

L = K 

TVB =0.0 

ZB = 0.0 

DO 10 I = 1,K 

TVB = TVB + PTEMP (I) 

10 ZB = ZB + ALT(I) 

IF(ISW.EQ.O) GO TO 20 
TVB = TVB + TVP 
ZB = ZB + ZP 
L = L + 1 

20 TVB = TVB /FLOAT (L) 

ZB = ZB/ FLOAT (L) 

51 = 0.0 

52 = 0.0 

DO 30 I - l.K 

SI = S1+(ALT(I)-ZB)*(PTEMP(I)-TVB) 

30 S2 = S2+(ALT(I)-ZB)**2 
IF(ISW.EQ.O) GO TO 40 

51 - S1+(ZP-ZB)*(TVP-TVB) 

52 = S2+(ZP-ZB)**2 
40 DPDZ = S1/S2 

50 CONTINUE 
RETURN 
END 


S2300000 

S2300010 

S2300020 

S2300030 

S2300040 

S2300050 

S2300060 

S2300070 

S2300080 

S2300090 

S2300100 

S2300110 

S2300120 

S2300130 

S2300140 

S2300150 

S2300160 

S2300170 

S2300180 

S2300190 

S2300200 

S2300210 

S2300220 

S2300230 

S2300240 

S2300250 

S2300260 

S2300270 

S2300280 
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FUNCTION TPZ(A,B,C,D,E) 

. , UPDATE: 8213 SOURCE: 16 DEC 81 LOCATION: KSC 


TPZ = (A-B)*(C-D)/(A-E) 

RETURN 

END 


S2400000 

S240001C 

■S2400020 

S2400030 

S2400040 

S2400050 
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n n o 


FUNCTION ARCOS(X) 

UPDATE: 8213 SOURCE; 06 FEB 81 LOCATION: KSC 


THIS RELATION HOLDS FOR ALL PRINCIPAL VALUES OF X. 
1.570796 = PI/2. 

ARCOS =0.0 
IF (X-1.0) 10,20,10 

10 ARCOS = 1.570796 - ATAN(X/SQRT(1.-X*X)) 

20 RETURN 
END 


S2500000 

S250G010 

S2500020 

S2500030 

S2500040 

S2500050 

S2500060 

S2500070 

S2500080 

S2500090 
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SUBROUTINE RRDRll S2600000 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S2600010 

C S2600020 

C S2600030 

C : :S2600040 

C : THIS SUBROUTINE COMPUTES THE NEW LAYER BOUNDARIES AND :S2600050 

C : PARAMETERS. ;S2600060 

C : :S2600070 

C S2600080 


C S2600090 

CC S2600100 

C**** BEGINCOMMONAREA . ****S2600110 

C 04/02/82 ■ S2600120 

C math PARAMETERS AND CONSTANTS S2600130 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S2600140 

C INPUT OPTIONS S2600150 

REAL LAMBDA , S 2 600 160 

INTEGER FILE, GOOD, TITLE S2600170 

C01!M0N /INPUT/ IRUN.NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S2600180 

I SHAPE, GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S2600190 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S2600200 

IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,BOTLAY, S2600210 

ZRK, DECAY, GOOD, NCIS0,NDIS0,NTIS0,FILE(3) S2600220 

.RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S2600230 

,IPLLNT(4),GAMMAP(30),HM(2),CISO(10),DISO(10), S2600240 

TISO(10),TITLE(14),SIGPP(29),SIGLL(29),VS(20), S2600250 

FS(20) ,MDLNAM(12) ,DBAR(20) S2600260 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S2600270 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S2600280 

MODEL4, MODELS, M0DEL6 S2600290 

INTEGER RUNNUM,RT,CL,CS S2600300 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,OT,HEAT,ZM,H, S2600310 

DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S2600320 

SIGZ, ISNDFO, CRT, LAYTOP(3) ,ITDU, KEEP S2600330 

.MIXING, MAXDEP, LAYBOT (3) . S2600340 

. , ALTSV, BATCH, CL(14), CS(IO) , GASSET, lAGAIN, S2600350 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , S2600360 

MINUS1,MINUS9,MINS1,MINS9, S2600370 

MODEL4, MODELS, MOD EL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S2600380 
RT(24) ,TPROPC,IDXRT S2600390 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S2600400 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S2600410 

. TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S2600420 

CLRLNE,INSLNE, DELINE S2600430 

COMFION /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S2600440 

INVNDR(2) ,ULINE(2) , S26004S0 

TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP .S2600460 
CLRLNE.INSLNE, DELINE, S2600470 

. IESCAJC3) ,NULL,IBLNK, S2600480 

IPAR(S) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S2600490 

C VEHICLE PARAMETERS S260OSOO 
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COMMON /VCLPR/ VPAR(17) c9fino=;9n 

C TIME PARAMETERS ^ 

COMMON /TIME/ JTIME, JDAY,JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, cofinn^iAn 

. LDAY,LYEAR,ISM0N(2) ,JMON(2) ,LKON(2) ,LSDT(2) S26005 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , co(;nn=^7n 

RH(30),PTEMP(30).SIGEP(30),SIGAP(30) S2600580 

^ COMMOWLMER/ DXX,DYY,DX(29).DY(29),Q(29),RISTIM(29),SIGX0(29), ^2600600 

SIGYO(29) b^DUUouu 

c 1 CALCULATED BOUNDRY DATA (FOR NEW LAYERS) 

COMMON /BLAYR/ DIRB (6) , SPEEDB (6) ,TEMPB(6) 

C —CALCULATED NEW LAYER PARAMETERS n 

CCHMON /NLYEK/ DBIR(32) .DIRNDa) ,DSPEED(32) , SIGAP»(32) ,SIOEPN(32) .S2600 40 
SPEEDN(32) 

C CONVERSION FACTORS S2600670 

COMMON /CNVRT/ QCONV (4) ,QPDEPH S2600680 

C**»***«**COMMOB BUFFER ARRAY FOR COMMON MODIFICATION******************S2600690 
COMMON /EXTRA/ BCOM(l). NTOTAL(l), PLUS(900) 52600,00 

C READ/WRITE BUFFER ^ ^ ^ + 2 * 900 = 3879S2600720 

cI***I-t*L**************^^********************************^ 

C EQUIVALENCE STATEMENTS cofinOTfin 

EQUIVALENCE(IIU,IPAR(1)).(I0U,IPAR(2)).(IPU1.IPAR(3)) 

,(IPU2.IPAR(4)),(IPU3,IPAR(5)) coftSo^sO 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) I 26 OO 79 O 

E N U 0 F C 0 « H 0 N A R E A *“*|fer08r0 

Cc S2600820 

C S2600830 

REAL MPWR S2600840 

DIMENSION ANG(30) ,DIREC(3) 92600850 

_ _ DTTT*^TTT' VORMA.TS 

900rFOWlAT(lH1.10(lH*),3X,48HCALCULATED INPUT METEOROLOGICAL LAYER ^^^^2600860 

. AMETERS , 4X , 1 0 ( 1H>^) / / 2X , 4HMET . , 1 9X , 4HWIND . 1 9X , JH^IOT , / 92600880 

9Y 9mAYFR 7X 4HWIND 7X,5HSPEED,8X,4HWIND,5X,9HDIRECTION, S2600880 

‘.Sx’.SHSIGMa’ofUx.SHsIgMA 0F/3X.3HN0. .7X,5HSPEED 7X 5KSHEAR.5 
QHDTRFrTION 3X 9H SHEAR ,4X,7HAZI ANG,5X,7HELE ANG/ rnnnm 

!!i1X.7H(M/SEC);5X,7H(M/SEC),6X.5H(DEG),19X,5H(DEG).7X.5H(DEG)) |2600910 

9002 FORMAT (IX, 40 (2H )) R2600930 

9^04 fS(//Ix!16(1h*)!4X^ layer PARAMETERS, S2600940 

,5X,16(1H*)) S2600960 

9005 FORMAT(/26H TRANSITION LAYER NUMBER: ,12,/) S2600970 

9006- F0RMAT(40X,4HWIND, 14X,4HWIND, / coAnnQRn 

. , 5HSIGNA , 4X , 5HSIGMA , / 3X , 2HAT , 6X , 6HHEIGHT , 4X , 5HTEMP . . 4X , 5HSPEED , 4X ^260 9 

5HSHEAR,5X,AHDIR. ,4X,5HSHEAR,5X,4HAZI, ,5X,4HELE. / coAmmn 

. ’, 9X,8H (METERS) , IX, 7H(DEG K) , 3X, 7H(M/SEC) , 13X,5H(DEG) , 13X, 92601020 

.5H(DEG),5X,51I(DEG)/40(2H-)) S2601U2U 
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n n o n 


9007 FORMAT (1X.7HT0P: . 3 (IX, F8. 2) , 10X.F8. 2 ,9X,2 ( 1X.F8. 4) ) 

9008 F0RMAT(1X,7HLAYER: . 18X, 4 (1X,F8. 2) , 2 (1X,F8.4) ) 

9009 FORMAT(lX,7HBOTTOM; ,3(1X,F8.2) , 10X,F8.2,9X,2(lX,F8.4) /40C2H— 'I'l 

9010 FORMAT(38HO* PROCESSING CONTINUES WITH NEXT RUN./lHl) 


initialize some constants and VARIABLES 
RAD=. 01745329 
NLAYS=NUM-1 
ZRL=ZRK 


Il=-1 

CALCULATE NEW LAYER BOUNDRY PARAMETERS 
DO 10 1=1, KBK 
11=11+2 
IJ=II+1 

KTAL=LAYBOT(I) 

NTAK=LAYTOP(I)+l 
SPEEDB(II)=SPEED(NTAL) 

SPEEDB (IJ) =SPEED (NTAK) 

SIGAPB(II)=SIGAP(NTAL) 

SIGAPB ( IJ) =SIGAP (NTAK) 

SIGEPB(II)=SIGEP(NTAL) 

SIGEPB ( IJ) =SIGEP (NTAK) 

DIRB(II)=DIR(NTAL) 

DIRB(IJ)=DIR(NTAK) 

TEMPB (II ) =PTEMP (NTAL) 

TEMPB ( I J ) =PTEMP (NTAK) 

10 CONTINUE 

CALCULATE PARAMETERS FOR SUBLAYERS (1 TO NLAYS) 
C TAUOK=TAUK 

C TAUOL=TAUOK 

C TAUL=TAUK 

C ST01=((TAUK/TAU0K)**.2)*RAD 

C ST02=((TAUK/600.0)**.2)*RAD 

TAUOK=600.0 
FAC= (TAUK/TAUOK) ** . 2 
S=ALT(2)/ZRK 
S1=1.0/ALOGT(S) 

^ COMPUTE SPEED, SIGMAP,SIGMEP FOR ALL SUBLAYERS 

c *** layer 1 *** 

P=RB8 ( SPEED ( 2 ) , SPEED ( 1 ) , S 1 ) 

SPEEDN(1)=RB11 (SPEEDO) ,P,ALT(2) ,ZRK) 

PPWR=P 

C P=RB8(SIGAP(2) ,SIGAP(1) ,S1) 

C SIGAPN(1)=ST01*RB11 (SIGAP(l) ,P,ALT(2) ,ZPJC) 

C MP17R=P 

C P=RB8(SIGEP(2),SIGEP(1),S1) 

C SIGEPN(1)=RB11 (SIGEPU) ,P,ALT(2) ,zrk)*rad 

C qpwr=p 

1F(NLAYS.LT.2) GO TO 30 
C *** LAYERS 2 TO NLAYS *** 

DO 20 1=2, NLAYS 
J=I+1 


S2601030 

S2601040 

S2601050 

S2601060 

S2601070 

S2601080 

S2601090 

S2601100 

S2601110 

S2601120 

S2601130 

S2601140 

S2601150 

S2601160 

S2601170 

S2601180 

S2601190 

S2601200 

S2601210 

S2601220 

S2601230 

S2601240 

S2601250 

S2601260 

S2601270 

S2601280 

S2601290 

S2601300 

S2601310 

S2601320 

S2601330 

S2601340 

S2601350 

S2601360 

S2601370 

S2601380 

S2601390 

S2601400 

S2601410 

S2601420 

S2601430 

S2601440 

S2601450 

S2601460 

S2601470 

S2601480 

S2601490 

S2601500 

S2601510 

S2601520 

S2601530 

S2601540 
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no on 


SPEEDN(I) = .5*(SPEED(J)+SPEED(D) 
SIGAPN(I)=.5*ST02*(SIGAP(J)+SIGAP(I)) 

12 SIGEPN(I)=.5*RAD*(SIGEP(J)+SIGEP(I)) 

20 CONTINUE 

CALCULATE WIND DIRECTION AND WIND SHEAR FOR SUBLAYERS 

*** LAYERS 1 TO NLAYS *** 

30 DO 90 1=1, NLAYS 
J=I+1 

IFdSIG.EQ. 1) GO TO 40 
IF(ALT(J) .NE.HM(l)) GO TO 40 
SIGAPN(I)=SIGAP(I)*FAC 
SIGEPN(I)=SIGEPd)*FAC 
GO TO 50 

40 SIGAPN(I)=,5*(SIGAP(J)+SIGAP(I))*FAC 
SIGEPN(I)=.5*(SIGEP(J)+SIGEP(I))*FAC 
50 IF(SIGAPN(I) .LT. 1.0) SIGAPN(I)=1 . 0 
IF(SIGEPNd) .LT. 1.0) SIGEPN(I) = 1.0 
DIRNd) = .5*(DIR(J)+DIR(I)) 

IF(ABS(DIR(J)-DIR(I)).LE. 180.0) GO TO 60 
DIRN(I)=DIRN(I) -180.0 
60 DDIR(I)=DIR(J)-DIRd) 

IF(DDIR(I).LE. 180.0) GO TO 70 
DDIR(I)=360.0-DDIR(I) 

70 IF(DDIR(I) .GE. -180.0) GO TO 80 
DDIRd)=DDIR(I)+360.0 
80 DSPEED(I)=SPEED(J)-SPEED(I) 

IF(DSPEED(I).GE.0.0) GO TO 90 
IF((PTEMP(J)-PTEMP(I)).GT.O.O) GO TO 90 
DSPEED(I)=ABS (DSPEED (I) ) 

90 CONTINUE 

C CALCULATE PARAMETERS FOR NEW LAYERS (1 TO NBK) 

IF(ISIG.EQ. 1) GO TO 110 
DO 100 1=1, NBK 
NLAYSI=NLAYS+I 
Ml=LAYBOT(I) 

M2=LAYTOP(I) 

SIGAPN(NLAYSI)=.5*RAD*(SIGAP(M2)*FAC+SIGAP(M1)*FAC) 

SIGEPN (NLAYSI) = . 5*RAD* (SIGEP (M2 ) *FAC+SIGEP (Ml ) *FAC) 

100 CONTINUE 
GO TO 130 

110 DO 130 1=1, NBK 

IF(IRUN.EQ.4) WRITE (lOU, 9011) I 

9011 F0RMAT(/22H DIAGNOSTICS FOR LAYER, 12, 16H FOR SIGMA, SIGME) 
NLAYSI=NLAYS+I 
Ml=LAYBOT(I) 

M2=LAYT0P(I) 

M21=M2+1 

DPLAY= ALT (M2 1 ) -ALT (Ml) 

DPLAYI= 1 /DPLAY 
TMP1=0.0 
TMP2=0.0 
DO 120 J=M1,M2 


S2601550 

S2601560 

S2601570 

S2601580 

S2601590 

S2601600 

S2601610 

S2601620 

S2601630 

S2601640 

S2601650 

S2601660 

S2601670 

S2601680 

S2601690 

S2601700 

S2601710 

S2601720 

S2601730 

S2601740 

S2601750 

S2601760 

S2601770 

S2601780 

S2601790 

S2601800 

S2601810 

S2601820 

S2601830 

S2601840 

S2601850 

S2601860 

S2601870 

S2601880 

S2601890 

S2601900 

S2601910 

S2601920 

S2601930 

S2601940 

S2601950 

S2601960 

S2601970 

S2601980 

S2601990 

S2602000 

S2602010 

S2602020 

S2602030 

S2602040 

S2602050 

S2602060 
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K=J+1 

ALTD=ALT(K)-ALT(J) 

TMP1=TMP1+(ALTD*(0.5*RAD*FAC*(SIGAP(K)+SIGAP(J)))) 

TMP2=TMP2+ ( ALTD* (0 . 5*RAD*FAC* ( S IGEP (K) +SIGEP ( J) ) ) ) 

IF(IRUN.EQ.4) WRITE(IOU,9012) J,K,ALT(J) ,ALT(K) ,SIGAP(J) ,SIGAP(K) 
. ,SIGEP(J) ,SIGEP(K) , ALTD, FAC, IMP 1.TMP2 
9012 FORMAT(3H J=,I2,3H K=,I2,8H ALT(J)=,F10. 3, 

.8H ALT(K)=,F10.3,10H SIGAP( J)= , FIO. 5 , lOH SIGEP(K)=, FIO. 5 , 

.lOH SIGEP(J)=,F10.5,10H SIGEP(K)=,F10.5/6H ALTD= ,F10. 3 , 5H FAC=, 
.F10.5.6H TMP1=,F10.5,6H TMP2=,F10.5) 

120 CONTINUE 

SIGAPN(NLAYSI)=TMP1*DPLAYI 
SIGEPN(NLAYSI)=TMP2*DPLAYI 
130 CONTINUE 

C CALCULATE WIND SPEED AND DIRECTION FOR TRANSITION LAYERS 

DO 240 1=1, NBK 

NLAYSI=NLAYS+I 

IBDX1=2*I-1 

IBDX2=2*I 

M1=LAYB0T(I) 

M2=LAYT0P(I) 

M21=M2+1 

S=0,0 

DO 140 J=M1,M2 
JJ= J+ 1 

140 S=S+.5*(SPEED(J)+SPEED(JJ))*(ALT(JJ)-ALT(J)) 

SPEEDN (NLAYSI ) = S / (ALT (M2 1 ) -ALT (Ml ) ) 

T1=DIR(M1) 

T2=0.0 

ANG(M1)=T1 

S=0.0 

DO 170 J=M1,M2 

JJ=J+1 

T2=DIR(JJ) 

IF(ABS(T2-T1) .LE. 180.0) GO TO 160 
IF(T2.GT.T1) GO TO 150 
T2=T2+360.0 
GO TO 160 
150 T2=T2-360.0 
160 P=.5*(T2+T1) 

T1=T2 

ANG(JJ)=T1 

170 S=S+P*(ALT(JJ)-ALT(J)) 

DIRN (NLAYSI) =S / (ALT (M2 1 ) -ALT (Ml ) ) 

C CALCULATE WIND DIRECTION SHEAR FOR ALL LAYERS 

T1=0.0 

T2=0.0 

DO 180 J=M1,M21 
T1=T1+ALT(J) 

180 T2=T2+ANG(J) 

P=1.0/FLOAT(M21-M1+1) 

T2=T2*P 


S2602070 

S2602080 

S2602090 

S2602100 

S2602110 

S2602120 

S2602130 

S2602140 

S2602150 

S2602160 

S2602170 

S2602180 

S2602190 

S2602200 

S2602210 

S2602220 

S2602230 

S2602240 

S2602250 

S2602260 

S2602270 

S2602280 

S2602290 

S2602300 

S2602310 

S2602320 

S2602330 

S2602340 

S2602350 

S2602360 

S2602370 

S2602380 

S2602390 

S2602400 

S2602410 

S2602420 

S2602430 

S2602440 

S2602450 

S2602460 

S2602470 

S2602480 

S2602490 

S2602500 

S2602510 

S2602520 

S2602530 

S2602540 

S2602550 

S2602560 

S2602570 

S2602580 



T1=T1*P 

P=0.0 

S=0.0 

DO 190 J=M1,M21 
P=P+(ALT(J)-T1)*(ANG(J)-T2) 

TTT=(ABS(ALT(J)-T1)**2) 

S=S+TTT 
190 CONTINUE 

DDIR(NLAYSI) = (ALT (M2 1 ) -ALT (Ml ) ) *P/S 
IF(DDIR(NLAYSI) .LE. 180.0) GO TO 200 
DDIR(NLAYSI)=360.0-DDIR(NLAYSI) 

200 IF(DDIR(NLAYSI).GE. -180.0) GO TO 210 
DDIR(NLAYSI)=360.0+DDIR(NLAYSI) 

C CALCULATE CHANGE IN WIND SPEED FOR ALL NEW LAYERS 

210 T1=0.0 
T2=0.0 

DO 220 J=M1,M21 
T1=T1+SPEED(J) 

T2=T2+ALT(J) 

220 CONTINUE 

P=1.0/FLOAT(M21-M1+1) 

T1=T1*P 

T2=T2*P 

P=0.0 

S=0.0 

DO 230 J=M1,M21 
P=P+(ALT(J) -T2)* (SPEED (J)-Tl) 

TTT=(ABS(ALT(J)-T2)**2) 

S=S+TTT 
230 CONTINUE 

DSPEED (NLAYSI) = (ALT (M2 1 ) -ALT (Ml ) ) *P/S 
IF(DSPEED(NLAYSI) .GE.0.0) GO TO 240 
IF((TEMPBhBDX2)-TEMPB(IBDXl)).GT.0.0) GO TO 240 
DSPEED (NLAYSI) =ABS (DSPEED (NLAYSI) ) 

240 CONTINUE 

250 IF(IPRINT.GT.l) GO TO 290 

C OUTPUT LAYER PARAMETERS 

260 WRITE(IOU,9001) 

WRITE (lOU, 9002) 

DO 270 I=1,NLAYS 
DIRNP=DIRNa) 

IF(DIRNP.LT.O.O) DIRNP=DIRNP+360. 0 
IF(DIRNP.GT. 360.0) DIRNP=DIRNP-360. 0 

WRITE(IOU,9003) I.SPEEDN(I) ,DSPEED(I) ,DIRNP,DDIR(I) , SIGAPN(I) 
. .SIGEPN(I) 

270 CONTINUE 

WRITE (lOU, 9004) 

DO 290 1=1, NBK 

J=2*I 

K=J-1 

L=NLAYS+I 

M=LAYT0P(I)+1 


S2602590 

S'2602600 

S2602610 

S2602620 

S2602630 

S2602640 

S2602650 

S2602660 

S2602670 

S2602680 

S2602690 

S2602700 

S2602710 

S2602720 

S2602730 

S2602740 

S2602750 

S2602760 

S2602770 

S2602780 

S2602790 

S2602800 

S2602810 

S2602820 

S2602830 

S2602840 

S2602850 

S2602860 

S2602870 

S2602880 

S2602890 

S2602900 

S2602910 

S2602920 

S2602930 

S2602940 

S2602950 

S2602960 

S2602970 

S2602980 

S2602990 

S2603000 

S2603010 

S2603020 

S2603030 

S2603040 

S2603050 

S2603060 

S2603070 

S2603080 

S2603090 

S2603100 
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N=LAYBOT(I) 

DIREC(1)=DIRB(J) 

DIREC(2)=DIRN(L) 

direcO)=dirb(k) 

SIGMA=SIGAPN(L)*57.2958 
SIGME=SIGEPN (L) *57 . 2958 

DO 280 IDX=1,3 ^ o 

IF (DIREC ( IDX) . LT . 0 . 0) DIREC (IDX) =DIREC (IDX) +360 . 0 
IF (DIREC ( IDX) . GT . 360 . 0) DIREC ( IDX) =DIREC (IDX) -360 . 0 


280 CONTINUE 

SIGMA1=SIGAP(M)*FAC 
SIGME1=SIGEP (M) *FAC 
SIGMA2=SIGAP(N)*FAC 
SIGME2=SIGEP(N)*FAC 
WRITE (lOU, 9005) I 
WRITE(IOU,9006) 

TOITE(IOU,9007)ALT(M) ,TEMPB(J) ,SPEEDB(J) ,DIREC(1) .SIGMAl .SIGMEl 
WRITE(IOU»9008) SPEEDN(L) ,DSPEED(L) ,DIREC(2) ,DDIR(L) , SIGMA, SIGME 
WRITE ( lOU ,9009) ALT (N) , TEMPB (K) , SPEEDS (K) ,DIREC (3) , SIGMA2 , SIGME2 

290 CONTINUE 
RETURN 
END 


S2603110 

S2603120 

S2603130 

S2603140 

S2603150 

S2603160 

S2603170 

S2603180 

S2603190 

S2603200 

S2603210 

S2603220 

S2603230 

S2603240 

S2603250 

S2603260 

S2603270 

S2603280 

S2603290 

S2603300 

S2603310 

S2603320 
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FUNCTION RB8(A,B,C) 

, UPDATE: 8213 SOURCE: 06 FEB 81 LOCATION: KSC 

*RB8=AL0GT(A/B)*C 
IF(RB8+1.0) 20,10,20 
10 RB8=-. 999999 
20 RB8=RB8+1.0 
RETURN 
END 


S2700000 

S2700010 

S2700020 

S2700030 

S2700040 

S2700050 

S2700060 

S2700070 



FUNCTION RB11(A,B,C,D) S2800000 
. , UPDATE: 8213 SOURCE: 06 FEB 81 LOCATION: KSC S2800010 
RB11=A*(C**B-D**B)/(B*(C-D)*D**(B-1.0)) S2800020 
RETURN S2800030 
END S2800040 
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REEDM SOURCE MODULE &RMMRM 


ickii-k 


ETNA 

PROGRAM RMMRM(5,120) 

. , UPDATE; 8213 SOURCE: 02 APR 82 LOCATION; KSC 

C***A DECLARATIONS. 

C 

Cc 

C**** BEGIN COMMON AREA 

04/02/82 

MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY . GAMilAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT , S IGMAR , SIGMER , LS ITE , BOTLAY , 

ZRK, DECAY, GOOD, NCISO.NDISO.NTISO, FILED) 

, RAINRT , LAFffiDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DIS0(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS ,MODEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS ,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK, SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING, MAXDEP.LAYBOT (3) 

, ALTSV , BATCH , CL ( 1 4 ) , CS ( 1 0 ) , GASSET , I AGAIN , 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5),IFRMT(80), 
MINUS1,MINUS9,MINS1,MINS9, 

MODEL4 , MODELS ,MODEL6 ,NNNEST,NNNTRY,LLNEST,LLNTRY , 
RT(24) ,TPROPC,IDXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

. CLRLNE,INSLNE, DELINE 

COMMON /CNTRL/ ALTSETD) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2) , 

. TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

. CLRLNE,INSLNE, DELINE, 

. lESCAJ D ) . null , IBLNK , 

IPAR ( S ) , ICU , lYS J , lYES J , INJ , INO J , NAMEP (3 ) 

C VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 

C TIME PARAMETERS 

COMMON /TIME/ JTIME, JDAY, JYEAR, ISTIME,ISDAY,ISYEAR,LTIME, 

LD AY , LYEAR , I SMON ( 2 ) , JMON ( 2 ) , LMON ( 2 ) , LSDT ( 2 ) 


S2900000 

S2900010 

S29C0020 

S2900030 

S2900040 

S29000SO 

S2900060 

S2900070 

S2900080 

S2900090 

S2900100 

S2900110 

S2900120 

S2900130 

S2900140 

S29001S0 

S2900160 

S2900170 

S2900180 

S2900190 

S2900200 

S2900210 

S2900220 

S2900230 

S2900240 

S29002S0 

S2900260 

S2900270 

S2900280 

S2900290 

S2900300 

S2900310 

S2900320 

S2900330 

S2900340 

S29003S0 

S2900360 

S2900370 

S2900380 

S2900390 

S2900400 

S2900410 

S2900420 

S2900430 

S2900440 

S29004S0 

S2900460 

S2900470 

S2900480 

S2900490 
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c SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S2900500 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S2900510 

. RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S2900520 

C LAYER PARAMETERS S2900530 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S2900540 

SIGYO(29) S2900550 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S2900560 

COMMON /BLAYR/ DIRB (6) , SPEEDB (6) , TEMPB(6) S2900570 

C CALCULATED NEW LAYER PARAMETERS S2900580 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S2900590 
SPEEDN(32) S2900600 

C CONVERSION FACTORS S2900610 

COMMON /CNVRT/ QCONV(4) .QPDEPH S2900620 

C S2900630 


C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S2900640 
COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S2900650 

READ/WRITE BUFFER S2900660 

•ARRAY = 2077 +1 + 1 + 2 * 900 = 3879S2900670 

C***:fc*:>c ****:*:***** ***************ifc:^r****:fe*****:Sc******A**:fe*:*f *:*:************* 5 2 9006 80 




S2900690 

- 


DATA JVERSN/8213/ 

S2900700 

- 



S2900710 



CALL RMPAR(IFRMT) 

S2900720 



IF (IVERSN .NE. JVERSN) CALL LOADS^-1 ,0,0, 0,0, BATCH) 

S2900730 



GO TO (10,20) ,IFRMT(3) 

S2900740 


10 

CALL RMFRM(IFRMT) 

S2900750 

- 


GO TO 30 

S2900760 

- 

20 

CALL RMETM 

S2900770 


30 

CALL REEDM 

S2900780 

= 


STOP 

S2900790 

1 


END 

S2900800 

% 

1 
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SUBROUTINE RMFRM(IPASS) 

, , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION 


KSC 


• • « • 


ORGANIZATION: H. E. CRAMER CO., INC. 

WORK FOR: DR. J. B. STEPHENS (ES84) 

PROGRAM CODE: RMETM 

PROGRAM DESCRIPTION: ONE OF THE MODULES FOR ROCKET EXHAUST 

EFFLUENT DIFFUSION ANALYSIS ' (MULTI-LAYER) 

INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS 

OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS, PLOTS 


FORMAT STATEMENTS 


C 

c ******************************************************************** 

c * * 

C * THIS PROGRAM GENERATES A METEOROLOGICAL PROFILE OF A SOUNDING * 
C * ON THE PLOTTER * 

C * * 

C ******************************************************************** 

C 
C 

CF 
CF 

9001 FORMAT (12 , 1XA2 , A1 , 1X14) 

9002 FORMAT (14) 

9003 FORMAT (F6.1) 

9004 FORMAT (4l4) 

TYPE AND DIMENSION STATEMENTS 

INTEGER STARS , CRSPC , SETTAB , TAB , TAB2 , OFF , BKARO , BLNKNG , XRITEL , 

. CLRTAB . CLRDSP , CURLFT , CURSDN , DELINE , CLRLNE , CR, CURSUP ,ULINE 
. .ALTSET , ^ 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2), 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT, CLRDSP 
. CLRLNE , INSLNE , DELINE , 

IESCAJ(3),NULL.IBLNK, 

. IPAR(5),ICU,IYSJ,IYESJ,INJ,IN0J,NAMEP(3) . 

DIMENSION WSX(30) ,DTX(30) ,PTX(30) ,WDX(30) ,CURVEY(30) ,IPASS(2) 
DIMENSION XAX(3) ,YAX(3) ,XLINQ(38) ,YLINQ(22) 

DIMENSION IALTL(8) ,IP(5) 

DIMENSION IXNUM(13) ,IYNUM(26) 


S3000000 

S3000010 

S3000020 

S3000030 

S3000040 

S3000050 

S3000060 

S3000070 

S3000080 

S3000090 

S3000100 

S3000110 

S3000120 

S3000130 

S3000140 

S3000150 

S3000160 

S3000170 

S3000180 

S3000190 

S3000200 

S3000210 

S3000220 

S3000230 

S3000240 

S3000250 

S3000260 

S3000270 

S3000280 

S3000290 

S3000300 

S3000310 

S3000320 

S3000330 

S3000340 

S3000350 

S3000360 

S3000370 

S3000380 

S3000390 

S3000400 

S3000410 

S3000420 

S3000430 

,S3000440 

S3000450 

S3000460 

S3000470 

S3000480 

S3000490 

S3000500 

S3000510 
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DIMENSION AWDIROO) 

S3000520 


DIMENSION XL(5) ,YL(5) ,IDT(8) ,IPT(8) ,IWS(8) ,ITO(7) 

S3000530 


DIMENSION ISURL0(41),ISURL1(53) 

S3000540 


DIMENSION ISTL(12) 

S3000550 


DIMENSION LABALT(6) 

S3000560 


DIMENSION IPGEN(24) ,IHT(5) 

w ^ \y \y \J ^ \J V/ 

S3000570 


DIMENSION IWDL(9) ,IALPHA(10) ,IREG(2) ,IBUFR(33) 

S3000580 


DIMENSION IMET(2),ITOPV(2) ,IBOTV(2) 

S3000590 


DIMENSION IN(2) ,XRITEL(6) 

S3000600 



S3000610 

- 

EQUIVALENCE STATEMENT 

S3000620 



S3000630 


EQUIVALENCE (STBALT.H) , (IN, INI) , (IREG.REG, lA) . (IREG(2) ,IB) 

S3000640 


, (XLINQ(4) ,XLINQ4) , (XLINQ{6) .XLINQ6) , (XLINQ(8) ,XLINQ8) 

S3000650 


, (XLINQ(IO) ,XLINQA), (XLINQ(12) .XLINQC) 

S3000660 


, (XLINQ(14) ,XLINQE) , (XLINQ(16) .XLINQG) 

S3000670 

7 

, (XLINQC19) ,XLINQJ) , (XLINQ(2I) .XLINQL) 

S3000680 


, (XLINQC24) .XLINQO) . (XLINQ(27) .XLINQR) 

S3000690 

- 

, (XLINQC29) .XLINQT) , (XLINQ(31) .XLINQV) 

S3000700 

* 

, (XLINQC33) ,XLINQX) , (XLINQ(35) .XLINQY) 

S3000710 


,(XLINQ(37),XLINQZ) 

S3000720 


EQUIVALENCE (YLINQ(4) ,YLINQ4) , (YLINQ(6) .YLINQ6) , (YLINQ(8) ,YLINQ8) 

S3000730 

f 

, (YLINQ(ll) .YLINQB) , (YLINQ(13) .YLINQD) 

S3000740 

1 

, (YLINQ(16) ,YLINQG) , (YLINQ(19) .YLINQJ) 

S3000750 

_ 

, (YLINQ (21) , YLINQD 

S3000760 

i 


S3000770 

_ 

DATA STATEMENTS 

S3000780 

7 


S3000790 


DATA CRSPC/6440B/ 

S3000800 


DATA LABALT/2HAL,2HTI,2HTU,2HDE,2H (,2HM)/ 

S3000810 


DATA IEXP3/2H3 / 

S3000820 


DATA ISTL/2HSP , 2HEE , 2HD ( , 2HM/ , 2HS) 

S3000830 


,2H ,2HTE,2HMP,2H(D,2HEG,2H C,2H) / 

S3000840 

w 

DATA ISURL0/2HDA,2HTE,2H: ,8*2H , 

S3000850 

- 

2H T,2HIM,2HE: ,7*2H , 

S3000860 


2H P,2HLO,2HTT,2HED,2H A,2HT:,5*2H , 

S3000870 


2HFR,2HOM,2H F, 2HIL, 2HE: ,4*2H / 

S3000880 


DATA ISURL1/2HSU,2HRF,2HAC,2HE ,2HPR,2HES,2HSU,2HRE.2H: ,3*2H . 

S3000890 


2H M.2HB ,2*2H , 

S3000900 


2HDE,2HNS,2HIT,2HY: ,4*2H ,2HG/,2HM ,2*2H , 

S3000910 


2H (3,2H -,2H S,2HTA,2HB ,2HHT,2H: ,3*2H ,2H M,2*2H , 

,83000920 

w 

2H *,2H* ,2H- ,2HCA,2HLC,2H H,2HT:,4*2H ,2HM / 

S3000930 


DATA XLINQ/ 0.0, 0.0, 5.0 

S3000940 


, 20.0, 55.0 

S3000950 

M 

,181.0,216.0 

S3000960 


, 20.0,139.0 

S3000970 


,244.0,300.0 

S3000980 


,419.0,503.0 

S3000990 


,601.0,692.0 

S3001000 


,460.0,100.0,100.0 

S3001010 


,310.0,460.0 

S3001020 


,726.0,726.0,506.0 

S3001030 
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,763.0,768.0,768.0 
,308.0,336.0 
, 95.0,102,0 
,731.0,724.0 
,100.0,106.0 
,321.0,398.0 

. . ,468.0,538.0/ 

DATA YLINQ/ 5.0, 0.0, 0.0 

,488.0,488.0 
,473.0,473.0 
, 90.0, 90.0,378.0 
, 70.0, 70.0 
,378.0, 90.0, 90.0 
,512.0,512.0,507.0 
, 88.0, 92.0 
, 68.0, 72.0/ 

DATA IDT/2HDR,2HY , 2HTE, 2HMP, 2H (,2HDE,2HG ,2HC)/ 

DATA IPT/2HPO,2HT , 2HTE , 2HMP , 2H (,2HDE,2HG ,2HC)/ 

DATA IMINUS/lH-/ 

DATA IWS/2H1«,2HND,2H S, 2HPE, 2HED, 2H (,2HM/,2HS)/ 

DATA IWD/2HWI,2HND,2H D,2HIR,2H (,2HDE,2HG)/ 

DATA IALTL/2H A,2H L,2H T,2H I,2H T,2H 1J,2H D,2H E/ 

DATA IXNUM/2H10,2H-5,2H 0,2H 5,2H10,2H15,2H20,2H25,2H30,2H35 , 
2H40,2H45,2H50/ 

DATA IYNUM/2H ,2H 0,2H 3,2H00,2H 6,2H00,2H 9,2H00,2H12,2H00, 

1 2H15 , 2H00 , 2H18 , 2H00 , 2H2 1 , 2H00 , 2H24 , 2H00 , 2H27 , 2H00 , 2H30 , 2H00 
. ,2H33,2HOO,2H36,2HOO/ 

DATA IMET/2H(M,1H)/ 

DATA XRITEL/2H 0,2H 2,2H 4,2H 6,2H 8,2H10/ 

DATA BKARO,CR /20137B,15B/ 

DATA IHF/IHF/ 

C 

c**** FIRST EXECUTABLE STATEMENT. 

C 

IPUl = IPASS(l) 

INI = IAND(IPASS(2) ,177400B) + 40B 

C 

IF (IPAR(l) .EQ. 98) CALL LURQ(1 , IPUl , 1) 

C CALL SUBROUTINES PLTLU.SFACT, AND LLEFT TO INITIALIZE PLOTTER. 

C 

10 CALL PLTLU(IPUl) 

CALL SFACT(7.68,5. 12) 

CALL LLEFT 

20 WRITE(ICU,9005) BLNKNG,OFF,BKARO 
9005 FORMAT(10X,2A2,15HFORM GENERATION, 3 A2) 

C 

C* ********************************** 

C 

C THIS PROGRAM DRAWS THE MET PLOT FORM 

C 

C* ********************************** 

C 


S3001040 

S3001050 

S3001060 

S3001070 

S3001080 

S3001090 

S3001100 

S3001110 

S3001120 

S3001130 

S3001140 

S3001150 

S3001160 

S3001170 

S3001180 

S3001190 

S3001200 

S3001210 

S3001220 

S3001230 

S3001240 

S3001250 

S3001260 

S3001270 

S30012S0 

S3001290 

S3001300 

S3001310 

S3001320 

S3001330 

S3001340 

S3001350 

S3001360 

S3001370 

S3001380 

S3001390 

S3001400 

S3001410 

S3001420 

S3001430 

S3001440 

S3001450 

S3001460 

S3001470 

S3001480 

S3001490 

S3001500 

S3001510 

S3001520 

S3001530 

S3001540 

S3001550 
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c 

c DRAW LOWER LEFT POSITION MARK 

C 

CALL LINQ(XLINQ,YLINQ,3,0) 

C 

c DRAW THE DATE, TIME, LOCATION, AND FILENAME LABELS 

C 

CALL CHARQ(20.0,490.0,0,ISURL0,74,2, 1) 

CALL LINQ(XLINQ4,YLINQ4,2,0) 

CALL LINQ(XLINQ6,YLINQ4,2,0) 

CALL LINQ(XLINQY,YLINQ4,2,0) 

CALL LINQ(XLIN0Z,YLINQ4,2,0) 

C 

C DRAW THE SURFACE PRESSURE, DENSITY, 

C STABILIZATION HEIGHT, AND CALCULATION HEIGHT LABELS 

C 

CALL CHARQ (20.0, 475. 0,0,ISURL1, 105, 2,1) 

CALL LINQ(XLINQ8,YLINQ6,2,0) 

CALL LINQ(XLINQA,YLINQ6,2,0) 

CALL CHARQ (377.0, 478. 0,0,IEXP3, 1,2,1) 

CALL LINQ(XLINQC,YLINQ6,2,0) 

CALL LINQ(XLINQE,YLINQ6,2,0) 

C 

c PRINT SURFACE AND OTHER REQUIRED HEADERS. 

C 

C 

c DRAW ALTITUDE LABEL 

C 

30 CALL CHARQ(30.0,435.0,0,LABALT,12,2,1) 

DRAW DRY TEMPERATURE LABEL 
CALL CHARQ (30. 0,425. 0,0, IDT, 16, 2,1) 

DRAW POTENTIAL TEMPERATURE LABEL 
CALL CHARQ (30. 0, 415. 0,0,IPT, 16,2,1) 

DRAW WIND SPEED LABEL 
CALL CHARQ(30.0,405.0,0,IWS,16,2,1) 

* DRAW WIND DIRECTION LABEL 
CALL CHARQ(30.0,395.0,0,TWD,14,2,1) 

DRAW X AND Y AXES 
CALL LINQ(XLINQG,YLINQ8,3,0) 

DRAW X AXIS LABELS 
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cy n a non nnnnnnnnn non 


CALL CHARQ(100.0,70.0,0,ISTL,24,2,1) 

DRAW TICK MARKS ON X AXIS 

TIC = 70.0 
COORD =62.0 
DO 40 1=1,13 
TIC = TIC +30.0 
XL(1) = TIC 
XL(2) = TIC 

CALL LINQ(XL,YLINQJ,2,0) 

XL(1) = XL(1) + 15.0 
XL(2) = XL(1) 

IF(I .NE. 13)CALL LINQ(XL,YLINQJ,2,0) 

COORD = COORD +30.0 

IF(I .EQ. 1)CALL CHARQ(84.0, 80. 0,0,IMINUS, 1,2,1) 
40 CALL CHARQ(COORD,80.0,0,IXNUM(I),2,2,1) 

DRAW WIND DIRECTION AXIS 

CALL LINQ(XLINQJ,YLINQB,2,0) 

DRAW WIND DIRECTION AXIS LABEL 

CALL CHARQ(336.0,50.0,0,IWD,14,2,1) 

DRAW TICK MARKS ON WIND DIRECTION AXIS 

XL(1)=295.0 
TIC = 15.0 
DO 50 1=1,11 
XL(1)=XL(1)+ TIC 
XL(2)=XL(1) 

50 CALL LINQ(XL,YLINQL) 

DRAW TICK MARKS ON Y AXIS [LEFT SIDE] 


TIC = 66.0 
N = 1 

DO 60 1=1,13 
TIC = TIC + 24.0 
YL(1) = TIC 
YL(2) = TIC 

CALL CHARQ(64.0,YL-2.5,0,IYNUM(N),4,2,1) 
N - N + 2 

60 CALL LINQ(XLINQT,YL,2,0) 

DRAW Y AXIS LABEL 

COORD = 344.0 

DO 70 1=1,8 

COORD = COORD - 20.0 
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70 CALL CHARQ(30.0,COORD,0,IALTL(I),2,2,1) 

CALL CHARQ (30 . 0 , COORD-20 .0,0, IMET, 3 ,2,1) 

C 

c DRAW RIGHT HAND X AND Y AXES 

C 

CALL LINQ(XLINQL,YLINQD,3,0) 

TIC=484.0 

C00RD=496.0 

DO 80 1=0,10,2 

TIC=TIC+22.0 

XL(1)=TIC 

XL(2)=TIC 

CALL LINQ(XL,YLINQJ,2,0) 

TIC=TIC+22.0 

XL(1)=TIC 

XL(2)=TIC 

IF(I.LT.IO) CALL LINQ(XL,YLINQJ,2,0) 

CALL CODE 

CALL CHARQ(COORD,80.0,0,XRITEL(l/2+l),2,2,l) 
C00RD=C00RD+44 . 0 
80 CONTINUE 
C 

C LABEL RIGHT HAND X AXIS 
C 

CALL CODE 
WRITE(IALPHA,9006) 

9006 FORMAT (30HRANGE ALONG MEAN WIND DIR (KM)) 
CALL CHARQ(513.0,70.0,0,IALPHA,30,2,1) 

C 

c DRAW TIC MARKS ON RIGHT HAND Y AXIS 

C 

TIC=66.0 
N = 1 

DO 90 1=1,13 
TIC=TIC+24.0 
YL(1)=TIC 
YL(2)=TIC 

CALL CHARQ(734.0,YL-2.5,0,IYNUM(N),4,2.1) 
CALL LINQ(XLINQV,YL,2,0) 

N = N + 2 
90 CONTINUE 
C 

C DRAW UPPER RIGHT POSITION MARK 
C 

CALL LINQ(XLINQO,YLINQG,3,0) 

C 

C REMOVE "FORM GENERATION" 

C 

WRITE (ICU, 9007) CR,CLRDSP,BKARO. 

9007 FORMAT (50A2) 

C 

CALL URITE 
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CHECK FOR "F" 

IF(INl.EQ.IHF) GO TO 110 

100 WRITE(ICU,9008) BLNKNG,OFF,INVNDR,INV,OFF,ULINE,OFF,BKARO 

9008 FORMAT(57H DO YOU WANT TO PLOT ANOTHER IRETEOROLOGICAL PROFILE 
.?/5X,2A2,30HCHANGE PLOT PAPER BEFORE A YES.2A2 

, ,14X,1H(,2A2.1HY,2A2,2HES,2A2,4H OR ,2A2, 1HN,2A2,2H0) ,A2) 
READ (ICU,9007) INI 

WRITE ( ICU , 9 00 7 ) CURSUP , CURSUP , CR , CLRDSP , BKAKO 
IF (INl.EQ.IBLNK.OR.INl.EQ.IYSJ.OR.INl.EQ.IYESJ) GO TO 20 
IF (INl.EQ. INJ.OR.INI .EQ. INOJ) GO TO 110 
TOITE (ICU, 9009) INV,OFF,0,0 
GO TO 100 

9009 FORMAT (2A2.38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2,6H 
*,I2,1H.,I1/) 

no CONTINUE 
RETURN 
END 
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C_ - S3100000 

Q S3100010 

C S3100020 

C S3100030 

- S3100040 

SUBROUTINE LINQ(X,Y,LEN, IDUM) S3100050 

. , UPDATE: 8213 SOURCE: 18 JAN 79 LOCATION: KSC S3100060 

DIMENSION X(1),Y(1) S3100070 

CALL PLOT(.01*X(1) , .01*Y(1) ,3) S3100080 

DO 10 1=2, LEN S3100090 

CALL PLOT(.01*X(I) , .01*Y(I) ,2) S3100100 

10 CONTINUE S3 100 110 

CALL PLOT(.01*X(LEN) , .01*Y(LEN) ,3) S3100120 

RETURN S3 100 130 

S3100140 
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REEDM SOURCE MODULE &RMMRN 


FTN4 S3200000 

SUBROUTINE RMETM S3200010 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S3200020 

C: ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: : S3200030 

C: :s J J 5 ! S3200040 

C::: ::: S3200050 

C::: ::: S3200060 

C::: ORGANIZATION: H. E. CRAMER CO., INC. ::: S3200070 

C::: ::: S3200080 

C::: WORK FOR: DR. J. B. STEPHENS (ES84) ::: S3200090 

C::: ::: S3200100 

C::: PROGRAM CODE: RMETM ::: S3200110 

C:;: ::: S3200120 

C::: PROGRAM DESCRIPTION: ONE OF THE MODULES FOR ROCKET E3CHAUST S3200130 

C::: EFFLUENT DIFFUSION ANALYSIS (MULTI-LAYER) :: : S3200140 

C::: ::: S3200150 

C;:: INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS ::: S3200160 

C::: ::: S3200170 

C:;: OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS, PLOTS ::: S3200180 

C::: ::: S3200190 

C: : S3200200 

C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::s:!!:’’*ss S3200210 

C S3200220 

C ******************************************************************** S3200230 
C * * S3200240 

C * THIS PROGRAM GENERATES A METEOROLOGICAL PROFILE OF A SOUNDING * S3200250 

C * ON THE PLOTTER * S3200260 

C * * S3200270 

******************:^f ************************************************* S3200280 
Cc S3200290 

C**** BEGIN COMMON AREA ****S3200300 

C 04/02/82 S3200310 

C math PARAMETERS AND CONSTANTS S3200320 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S3200330 

C INPUT OPTIONS S3200340 

REAL LAMBDA S3200350 

INTEGER FILE, GOOD, TITLE S3200360 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S3200370 

ISHAPE,GAMMAX,GAMMAY,GAMMAZ,ALPHA,BETA, S3200380 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S3200390 

IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,B0TLAY, S3200400 

ZRK, DECAY, GOOD, NCIS0,NDIS0,NTIS0,FILE(3) S3200410 

,RAINRT, LAMBDA, TIM1.DURAT,NVS,IVERSN,L0CATN(2) S3200420 

,IPLLNT(4),GAMMAP(30),HM(2),CISO(10),DISO(10), S3200430 

TISO(10),TITLE(14),SIGPP(29),SIGLL(29),VS(20), S3200440 

FS(20) ,MDLNAM(12) ,DBAR(20) S3200450 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S3200460 

LOGICAL I SNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S3200470 

, M0DEL4 , MODELS , M0DEL6 S3200480 

INTEGER RUNNUM,RT,CL,CS S3200490 
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COMMON /CTRFL/ IFLG.RUNNUM, NUN, NLAYS,NBK,QC,QT, HEAT, ZM,H, S3200500 

DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S3200510 

SIGZ,ISNDFO,CRT,LAYTOP(3),ITDU,KEEP S3200520 

, MIXING, MAXDEP,LAYBOT (3) S3200530 

, ALTSV, BATCH, CL(14),CS(10), GASSET, lAGAIN, S3200540 

ICHAR(12),IDXCL,IDXCS,IERR0R(5),IFRMT(80), S3200550 

MINUS1,MINUS9,MINS1,MINS9, S3200560 

MODEL4, MODELS, M0DEL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S3200570 
. RT{24) ,TPROPC,IDXRT S3200580 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS.. S3200590 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S3200600 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S3200610 

. CLRLNE, INSLNE, DELINE S3200620 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S3200630 

INVNDR(2) ,ULINE(2) , S3200640 

. TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP ,33200650 


. CLRLNE, INSLNE, DELINE, S3200660 

. IESCAJ(3) ,NULL,IBLNK, S3200670 

IPAR(5),ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S3200680 

C VEHICLE PARAMETERS S3200690 

COMMON /VCLPR/ VPAR(17) S3200700 

C TIME PARAMETERS S3200710 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S3200720 

. LDAY,LYEAR,ISMON(2) ,JMON(2) ,LMON(2) ,LSDT(2) S3200730 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S3200740 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S3200750 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S3200760 

C LAYER PARAMETERS S3200770 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S3200780 

SIGYO(29) S3200790 

C-’'- CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S3200800 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S3200810 

C CALCULATED NEW LAYER PARAMETERS S3200820 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,33200830 
SPEEDN(32) S3200840 

C CONVERSION FACTORS S3200850 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S3200860 

C S3200870 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S3200880 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S3200890 

C READ/ITRITE BUFFER S3200900 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S3200910 

C*******Vc**********************:«r****:l:********************A*^*************S3200920 
C S3200930 

C EQUIVALENCE STATEMENTS S3200940 

EQUIVALENCE (I lU, IPAR( 1 ) ) , (lOU, IPAR(2) ) , (IPUl , IPAR(3) ) S3200950 

,(IPU2,IPAR(4)),(IPU3,IPAR(5)) S3200960 

EQUIVALENCE (MAXDEP,GRVSET) , (IFRMT(l) ,IFRIIT1) S3200970 

C S3200980 

C**** END OF COMMON AREA ****33200990 

CC S3201000 

C S3201010 
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DIMENSION RANGE(30,6) ,BEARNG(30,6) ,SIGYBR(30 ,6) ,CORSG(30,6) 
. ,RCORSG(6) ,BCORSG(6) ,XCORSG(6) 

C EQUIVALENCE STATEMENTS 

EQUIVALENCE 

. (PLUS, RANGE) , (PLUS (181) ,BEARNG) , (PLUS(361) .SIGYBR) 

. ,(PLUS(541),XC0RSG),(PLUS(547),C0RSG),(PLUS(727),RC0RSG) 

. , (PLUS (733) .BCORSG) 

EQUIVALENCE (PLUS(735) .LOOP) 

C 

CF FORMAT STATEMENTS 

CF 

9001 FORMAT (12 , 1XA2 ,Al , 1X14) 

9002 FORMAT U4) 

9003 FORMAT (F6.1) 

9004 FORMAT (414) 

C 

C TYPE AND DIMENSION STATEMENTS 

C 

INTEGER STARS , CRSPC , BKARO , CR , BKAKO , ZIP 

DIMENSION WSX(30) ,DTX(30) ,PTX(30) ,WDX(30) ,CURVEY(30) 

DIMENSION XAX(3),YAX(3),XLINQ(2) 

DIMENSION AWDIR(30) 

DIMENSION XL(5),YL(5) 

DIMENSION ISURT(20) 

DIMENSION ICRVT(4) ' . 

DIMENSION LALAB1(3) ,LALAB2(3) ,LALAB(16) 

DIMENSION IHT (5) 

DIMENSION IWDL(9),IALPHA(15) 

DIMENSION IT0PV(2) ,IBOTV(2) .ZIP (5) 

DIMENSION IN (2) 

C 

C DATA STATEMENTS 

C 

DATA CRSPC/6440B/ 

DATA LALAB 1 / 2 HLA , 2HYE , 2HR 1 / 

DATA LALAB2/2HLA,2HYE,2HR2/ 

DATA LALAB/16*2H / 

DATA TWDL/270,0,90, 180,270,360,90, 180,270/ 

DATA STARS/2H**/ 

DATA ICRVT/2HWS,2HDT,2HPT,2HWD/ 

DATA XLINQ/ 100. 0,106.0/ 

DATA ISURT /2HSU, 2HRF, 2HAC, 2HE ,16*2H / 

DATA ITOPV/2H T.2HOP/, IBOTV/2H B.2HOT/ 

DATA BKARO, CR, BKAKO, ZIP 
. /20137B,15B,137B,5*0/ 

DATA IHAT/1H0/ 

C 

C**** STATEMENT FUNCTIONS: 

C 

PLIM(R)=AMAX1(100.0,AMIN1(460.0,6.0*R+160.0)) 

C 

C**** FIRST EXECUTABLE STATEMENT. 
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c 

10 IF(GOOD.NE.O) GO TO 20 

WRITE ( ICU , 9005 ) DELINE , CLRDSP , SETTAB , CR , BKAKO 

9005 FORMAT(2A2,32X3A2) 

9006 FORMAT (50A2) 

9007 FORMAT( lOX, 2A2 , 8HPL0TTING, 3A2) 

C 

C 

C DETERMINE SOME X AND Y COORDINATES AND TOTAL NUMBER OF POINTS 

C FOR THE CURVES 

C 

20 IF(GOOD .GT. 0) WRITE(ICU, 9006) (CURSUP, I=-l , LOOP) .DELINE, 

1 (CURSDN, 1=1, LOOP) 

IKND = IBLNK 
IF (CRT) IKND = BKARO 

IF(GOOD.GE.O) WRITE (ICU, 9007) BLNKNG , OFF , IKND 
CALL PLTLU(IPUl) 

CALL SFACT(7.68,5.12) 

CALL LLEFT 

IF(GOOD.NE.O) GO TO 110 
30 DO 40 1=1, NUM 

IF(ALT(I) .GE. 3600. 0)GO TO 50 
CUKVEY(I) = ALT(I) * 0.08 + 90.0 
40 AWDIR(I) = DIR(I) 

I = NUM + 1 
50 ILP = I - 1 
C 

C CALL SUBROUTINE TO ROTATE WIND DIRECTION FOR PLOTTING 

C 

CALL WINDS(A17DIR,ILP,ISC) 

COORD=293.0 
DO 60 1=0,5 
CALL CODE 

WRITE(IALPHA,9002) IWDL(ISC+I) 

CALL CHARQ(COORD,60.0,0,IALPHA,4,2,1) 

60 COORD=COORD+30.0 
C 

C**** CALCULATE PLOTTER COORDINATES FOR WIND SPEED 
C**** TEMPERATURE, AND POTENTIAL TEMPERATURE. 

C 

DO 70 1=1, ILP 

WSX(I) = PLIM(SPEED(I)) 

DTX(I) = PLIM(TEMP(I)-273. 15) 

PTX(I) = PLIM(PTEMP(I)-273. 15) 

70 WDX(I) = ABS(AWDIRd)) * 0.333333 + 310.0 
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WRITE THE DATE, TIME OF THE DATA, INSTALLATION, AND DATA FILENAS3202000 

S3202010 


CALL CODE S3202020 
WRITE (IALPHA,9001) ISDAY,ISMON(l) ,ISMON(2) .ISYEAR S3202030 
CALL CHARQ(69. ,490. ,0,IALPHA, 11,2,1) S3202040 
CALL CODE S3202050 
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WRITE (IALPHA.9002) ISTIME 

IF ( I ALPHA (D.LT.30000B) I ALPHA ( 1 ) = lALPHA ( 1 ) + 1 OOOOB 
CALL CHARQ(230. ,490. ,0, IALPHA,4, 2 , 1) 

CALL CHARQ(258.0,490.0,0,LSDT,4,2,1) 

IFdPLACE .EQ. 0)G0 TO 80 

I = IPLACE - IPLACE/3 

CALL CHARQ (412.0,490.0, 0 ,L0CATN, 4 ,2,1) 

CALL CHARQ(552. 0,490. 0,0, FILE, 6, 2,1) 

C 

C WRITE THE SURFACE PRESSURE, DENSITY, STABILIZATION HEIGHT 

C AND CALCULATION HEIGHT. 

C 

80 CALL CODE 

WRITE (IALPHA,9003) PRESS(l) 

CALL CHARQ ( 153.0, 475. 0,0,IALPHA, 6, 2,1) 

CALL CODE 

WRITE (IALPHA,9003) SURDEN 
CALL CHARQ(314.0,475.0,0,IALPHA,6,2,1) 

CALL CODE 

WRITE (IALPHA,9003) H 
CALL CHARQ(517.0,475.0,0,IALPHA,6,2,1) 

CALL CODE 

WRITE(IALPHA,9003) CALHT 
lALPHA ( 2 ) =MAX0 ( I ALPHA ( 2 ) , 2 0 06 0 B ) 

CALL CHARQ(706. 0,475. 0,0, lALPHA, 6, 2,1) 

DRAW THE WIND SPEED LINE 

CALL PLOTQ (WSX , CURVEY , ILP , 1 ) 

COORD = CURVEY (ILP) +3.0 
CALL CHARQ(WSX(ILP),COORD,0,ICRVT(1),2,2,1) 

DRAW THE DRY TEMPERATURE LINE 

CALL PLOTQ (DTX, CURVEY, ILP, 0) 

COORD = CURVEY (ILP) - 8.0 

CALL CHARQ(DTX(ILP)+4.0,CO0RD,0,ICRVT(2),2,2,l) 

DRAW THE POTENTIAL TEMPERATURE LINE 

CALL PLOTQ(PTX,CURVEY,ILP, 1) 

COORD = CURVEY (ILP) +3.0 
CALL CHARQ (PTX ( ILP) , COORD , 0 , ICRVT (3 ) ,2,2,1) 

DRAW THE WIND DIRECTION LINE 

II - 1 

DO 90 1=2, ILP 

IF(AWDIRd) .GE. 0.0)G0 TO 90 
NUMP =1-11 

CALL PLOTQ (WDX (II), CURVEY (II), NUMP, 0) 

II = I 
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90 CONTINUE 

NUMP = ILP - II + 1 

CALL PLOTQ ( WDX ( I 1 ) , CURVEY ( I 1 ) , NUMP , 0 ) 

COORD = CURVEY (ILP) - 8.0 

CALL CHARO (OTX (ILP) +4 . 0 , COORD , 0 , ICRVT (4) , 2 . 2 , 1 ) 

C DRAW TICK MARKS AT THE VALID DATA POINTS ON THE Y AXIS 

C 

DO 100 1=1, ILP 

YL(1) = ALT(I) * 0.08 + 90.0 
YL(2) = YL(1) 

100 CALL PLOTQ (XLINQ.YL, 2,0) 

C 

c DRAW ** AT CALCULATION HEIGHT 

C 

COORD=CALHT*0 . 08+86 . 0 

CALL CHARQ( 115.0, COORD, 0, STARS, 2, 2,1) 

CALL CHARQ (705.0, COORD, 0, STARS, 2, 2,1) 

C 

c DRAW @ AT STABILIZATION HEIGHT 

C 

CALL CHARQ (6 16. 0,86. 5+0. 08*H,0,IHAT, 1,2,1) 

C 

c DRAW THE CLOUD 

C 

110 IF(GOOD.GT.O) CALL CLOUD 
C 

c WRITE OUT LAYER INTERFACE DATA AND PLOT IT 

C 

NLINE=0 

IHT(1)=1 

IHTX=2 

IF(LAYBOT(l).EQ.l) GO TO 120 
IHT(2)=LAYBOT(l) 

LXWRD=5 

NCHAR=40 

NXWRD=10 

NLINE=1 

IHTX=3 

ISURT(6)=IBOTV(l) 

ISURT(7)=IBOTV(2) 

GO TO 130 
120 NCHAR=32 
NXWRD=6 
LXWRD=1 

130 ISURT(NXWRD)=ITOPV(l) 

ISURT (NXWRD+ 1 ) =ITOPV ( 2) 

IHT ( IHTX) =LAYTOP ( 1 ) + 1 
NLINE=NLINE+1 
NXWRD=NXWRD+4 
IHTX=IHTX+1 

IF(LAYTOP(2).GT.O) GO TO 140 
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o n n o o n o 


LXWRD2=0 
NCHAR=NCHAR-16 
GO TO 150 
140 LXWRD2=LX\v’RD+8 

ISURT (NXWRD) = IBOTV ( 1 ) 

ISURT (NX\>TRD+ 1 ) =IBOTV ( 2) 

ISURT(NXWRD+4)=ITOPV(l) 

ISURT(NX\JRD+5) = ITOPV(2) 

IHT(IHTX)=LAYBOT(2) 

IHT ( IHTX+ 1 ) =LAYTOP ( 2 ) + 1 
NLINE=NLINE+2 

150 IF(GOOD.LT.O) GO TO 180 
LALAB (LXWRD) =LALAB 1(1) 

LALAB (LX1'JRD+ 1 ) =LALAB 1(2) 

LALAB ( LXIJRD + 2 ) =LAL AB 1(3) 

IF(LX\^RD2.GT.O) GO TO 160 
LCHAR=2* (LXWRD+2) 

GO TO 170 

160 LALAB(LXWRD2)=LALAB2(1) 

LALAB (LXWRD 2 + 1 ) =L ALAB 2 ( 2 ) 

LALAB (LXWRD 2 + 2 ) =LALAB 2(3) 

LCHAR=2*(LX1;RD2+2) 

170 CALL CHARQ(198. 0+LASET, 461.0,0, LALAB, LCHAR, 2,1) 

CALL CHARQ 063.0,451.0,0 , ISURT ,NCHAR, 2,1) 

180 DO 190 NL=1,NLINE+1 

XP= 1 00 . 0+56 . 0*FLOAT (NL) 

CALL MOVEM(IHT(NL) ,XP,NL,NLINE) 

190 CONTINUE 

IF(GOOD.GT.O) GO TO 200 
CALL PLOT(4.50,2.56,3) 

IF(GOOD.EQ.O) 

$ WRITE(ICU,9008) cr,clrdsp,tab,clrtab,cr,invhf,off 

9008 FORMAT ( 5 A2, 12H ***** ,2A2,34HDO NOT CHANGE PLOTTER PEN 

$0N,2A2,11H *****) 

RETURN 

PRINT DATE AND TIME PLOTTED . 

200 CALL FTIME(IALPHA) 

CALL CODE (80) 

READ (IALPHA,9009) (IFRMT(I) , 1=1 , 7) 

9009 FORMAT (A2, IX, A2 , 1 IX, A2 , 2X, A2 , A1 ,3X, 2A2) 

CALL CODE 

WRITE(IALPHA,9010) (IFRMT(I) , 1=1 , 7) 

9010 FORMAT (16HPLOTTED AT: *** ,2A2,2H, ,A2, 1X,4A2,4H ***) 

CALL CHARQ(499. ,7. ,0, lALPHA, 37 , 2 , 1) 

CALL URITE TO TERMINATE GRAPHIC MODE 
DELETE "PLOTTING" MESSAGE. 

CALL URITE 

WRITE(ICU,9006) CR,CLRLNE,BKAKO 
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TEPJIINATE RMETM 
RETURN 

END OF RMETM 


END 
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SUBROUTINE WINDS (ITO .I'M) , 1ST) 

. , UPDATE: 8213 SOURCE: 22 JAN 79 LOCATION: KSC 

C 

c 

c - 

C - THIS SUBROUTINE COMPUTES THE WIND DIRECTION LABELS - 
C - FOR PLOTTING 
C - 

c 

c 

DIMENSION DWD(30) ,STWD(4) ,ra(l) 

DATA STWD/270. 0,0. 0,90. 0,180.0/ 

TO1=WD(1) 

17DX=l>rol 
WDN=WD1 
DO 10 1=2, NWD 
WD2=WD(I) 

CALCULATE LAYER DIRECTIONAL SHEAR 
D\H5I=WD2-17D1 

IF(D17DI.LT. -180.0) DTOI=Dl>DI+360 . 0 
IF(DWDI.GT. 180.0) DWDI=DWDI-360. 0 
D1'JD(I)=D17DI 
WDI=17D(I-1)+DWDI 

FIND MINIMUM WIND DIRECTION WITH RESPECT TO WD(1) 

IFOTDI.LT.WDN) WDN=WDI 
WD(I)=WDI 
WD1=WD2 
10 CONTINUE 
WDNP=WDN 

IF(1'/DN.LT.0) WDN=WDN+360.0 

CALCULATE START INDEX FOR WIND DIRECTION LABEL 

IST=2+IFIX(WDN)/90 
IF(IST.GT.4) IST=1 

CALCULATE RELATIVE POSITION WITH RESPECT TO STWD(IST) 
WD ( 1 ) = WD ( 1 ) - WD NP +WDN- ST WD ( I S T ) 

DO 20 l=2,Nn'TO 
WD(I)=1'/D(I-1)+D1H)(I) 

IFOTD(I).LT.O.O) WD(I)=WD(I)+360.0 
IFO^D(I) .GT. 450.0) WD(I)=lrt)(I)-360.0 
20 CONTINUE 
RETURN 
END 
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onooooo on 


c 

c 

c 


SUBROUTINE CLOUD 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 


- THIS SUBROUTINE DRAWS THE CLOUD FOR THE MET 

- PROFILE, AT A SPECIFIED X AND Y POSITION. 


- S3400000 
S3400010 
S3400020 
S3400030 

- S3400040 
S3400050 
S3400060 
S3400070 
S3400080 
S3400090 
S3400100 
S3400110 
S3400120 


Cc 

c**** BEGINCOMMONAR'EA *i 

C 04/02/82 

c MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI , G, CP ,MAXLEV,GAMMAI ,GA1-1MAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I S HAPE , GAMMAX , G AMMAY , GAMMAZ , ALPHA , B ETA , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT, SIGMAR, SIGMER,LSITE,BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NDI SO , NTISO , FILE ( 3 ) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12),DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL I SNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

M0DEL4 , MODELS , M0DEL6 

INTEGER RUNNUM , RT , CL , CS 

COMMON /CTRFL/ IFLG, RUNNUM, NUM,NLAYS,NBK,QC,QT, HEAT, ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 
SIGZ,ISNDF0,CRT,LAYT0P(3) ,ITDU,KEEP 
, MIXING, MAXDEP, LAYB0T( 3) 

, ALTSV, BATCH, CL( 14) , CS (10) , GASSET, lAGAIN, 

. ICHAR(12) ,IDXCL,IDXCS,IERR0R(5),IFRMT(80), 

MINUS 1 , MINUS 9 , MINS 1 , MINS9 , 

M0DEL4 , MODELS , M0DEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24) ,TPROPC,IDXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

. CLRLNE.INSLNE, DELINE 

COMMON /CNTRL/ ALTSET(2) ,0FF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2), 


TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT, CLFJISP , S3400S00 
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CLRLNE.INSLNE, DELINE, S 34005 10 


IESCAJ(3) .NULL.IBLNK, S3400520 

IPAR(5),ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S3400530 

C VEHICLE PARAMETERS S3400540 

COMMON /VCLPR/ VPAR(17) S3400550 

C : TIME PARAMETERS S3400560 

COMMON /TIME/ JTIME, JDAY,JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S3400570 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S3400580 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S3400590 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S3400600 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S3400610 

C LAYER PARAMETERS S3400620 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S3400630 

SIGYO(29) S3400640 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S3400650 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S3400660 

C-- CALCULATED NEW LAYER PARAMETERS S3400670 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) , SIGAPN(32) , SIGEPN(32) , S3400680 
. SPEEDN(32) S3400690 

C CONVERSION FACTORS S3400700 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S3400710 

C S3400720 


C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S3400730 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S3400740 

C -READ/raiTE BUFFER S3400750 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S3400760 


C 

c EQUIVALENCE STATEMENTS 

EQUIVALENCE (I lU, IPAR(1 ) ) , (lOU, IPAR(2) ) , (IPUl , IPAR(3) ) 
,(IPU2,IPAR(4)), (IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) , IFRMTl) 

C 

C**** ENDOF COMMON AREA 

CC 

C 

DIMENSION RANGE(30,6) ,BEARNG(30,6) ,SIGYBR(30,6) ,C0RSG(30,6) 
. ,RCORSG(6) ,BC0RSG(6hXC0RSG(6) 

C EQUIVALENCE STATEMENTS 

EQUIVALENCE 

* * (PLUS, RANGE), (PLUS(181),BEARNG),(PLUS(361),SIGYBR) 

. , (PLUS (541 ) ,XCORSG) , (PLUS (547) , CORSG) . (PLUS (727) .RCORSG) 

. , (PLUS (733) ,BCORSG) 

DIMENSION X(5),Y(5) 

REAL LEFT 

EQUIVALENCE (X, LEFT) , (Y,BOT) , (X(3) .RIGHT) , (Y(2) , TOP) 

DATA D2RAD/0. 01745329/ 

INDIR=NLAYS+1 

I F (H . GT . ALT ( LAYTOP ( 1 ) ) ) INDIR=NLAYS+2 
BOT=90.0+0.08*ALT(1) 

DO 20 I=1,NLAYS 

XCENTR=506 . 0+0 . 022*TAUK*SPEEDN(I) 


S3400780 

S3400790 

S3400800 

S3400810 

S3400820 

S3400830 

****S3400840 

S3400850 

S3400860 

S3400870 

S3400880 

S3400890 

S3400900 

S3400910 

S3400920 

S3400930 

S3400940 

S3400950 

S3400960 

S3400970 

S3400980 

S3400990 

S3401000 

S3401010 

S3401020 


141 




BOVRA=SIGPP(I)/SIGLL(I) 

S3401030 


THETAP=DIRN ( INDIR) -DIRN (I) 

S3401040 


B0VRA1= 1 . -BOVRA*BOVRA 

S3401050 


STP=SIN(THETAP*D2RAD) 

S3401060 


THETAR=ATAN (BOVRAl *STP*COS (THETAP*D2RAD) / ( 1 . -B0VRA1*STP*STP) ) 

S3401070 


CTMTP=COS((DIRN(I)-THETAP)*D2RAD) 

S3401080 


DX=SIGPP (I) *COS (THETAR) /SQRT( 1 . -B0VRA1*CTMTP*CTMTP) 

S3401090 


T0P=AMIN1 (90. 0+0. 08*ALT(I+1) , 378 . 0) 

S3401100 


LEFT=AMIN1(A>IAX1(XCENTR-0.022*DX, 506.0) ,726.0) 

S3401110 


RIGHT=AMAX1 (APIINl (XCENTR+0 . 022*DX , 726 . 0) , 506 . 0) 

S3401120 


IF(LEFT.EQ. RIGHT) GO TO 10 

S3401130 


X(2)=LEFT 

S3401140 


Y(3)=TOP 

S3401150 


X(4)=RIGHT 

S3401160 


Y(4)=BOT 

S3401170 


X(5)=LEFT 

S3401180 


Y(5)=BOT 

S3401190 


CALL PLOTQ(X,Y,5,0) 

S3401200 

10 

BOT=TOP 

S3401210 

20 

CONTINUE 

S3401220 


RETURN 

S3401230 


END 

S3401240 
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D o o o o o o n o o 


c 

c 

c 

c 

c 


SUBROUTINE MOVEM( JND , XPR.NL , NLINE) 

UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 


- THIS SUBROUTINE PLOTS LAYER BOUNDARIES, 


L** BEGINCOM MON AREA **** 

04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN , NUMRUN , MODEL , IVHICL , NORMAL , TPROP , 

I SHAPE, GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, ^ 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE, IPRINT, SIGMAR, SIGNER, LSITE.BOTLAY, 

ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE ( 3 ) 

RAINRT , LAMBDA , T IM 1 , DURAT , NVS , I VERSN , LOC ATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DIS0(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 

FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT , MAXDEP , BATCH , GAS SET , GRVSET , 

. MODEL4 ,MODEL5 ,MODEL6 

INTEGER RUNNUM,RT,CL,CS 

COMMON / CTRFL / I FLG , RUNNUM , NUM , NLAY S , NBK , QC , QT , HEAT , ZM , H , 

COMMON /OiKir ^pj^2;TAUK,SURDEN,ZRL,IB0T,IT0P,SIGXNK,SIGYNK, 

SIGZ, ISNDFO, CRT, LAYTOP( 3) ,ITDU,KEEP 
.MIXING, MAXDEP ,LAYBOT (3) 

.ALTSV, BATCH, CL(14) ,CS(10) , GASSET, I AGAIN, 

ICHAR(12) ,IDXCL.IDXCS,IERROR(5) ,IFRMT(80) , 

MINUS 1.MINUS9, MINS 1.MINS9, 

MODEL4 .MODELS .MODEL6 ,NNNEST ,NNNTRY,LLNEST,LLNTRY , 
RT(24) ,TPROPC,IDXRT 

terminal CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET.OFF.BLNKNG.INV.ULINE.INVNDR. 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

1 CLRLNE.INSLNE, DELINE ' 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2), 

* TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

’ CLRLNE.INSLN’E, DELINE, 
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lESCAJO) ,NULL,IBLNK, S3500510 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,IN0J,NAMEP(3) S3500520 

C VEHICLE PARAPIETERS S3500530 

COMMON /VCLPR/ VPAR(17) S3500540 

C“** ■*“* TIME PARAMETERS S3500550 

COMMON /TIME/ JTIME, JDAY, JYEAR, ISTIME, ISDAY, ISYEAR.LTIME, S3500560 

LDAY,LYEAR,ISMON(2).JMON(2),LMON(2),LSDT(2) S3500570 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S3500580 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S3500590 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S3500600 

C”— “ ""—LAYER PARAMETERS S3500610 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S3500620 

' SIGYO(29) S3500630 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S3500640 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S3500650 

C CALCULATED NEW LAYER PARAMETERS S3500660 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) .S3500670 
SPEEDN(32) S3500680 

C CONVERSION FACTORS ’ S3500690 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S3500700 

^ S3500710 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S3500720 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S3500730 

C READ/WRITE BUFFER S3500740 

C A R R A Y = 2077 +1 + 1 + 2 * 900 = 3879S3500750 

^ _ S3500770 

C EQUIVALENCE STATEMENTS S3500780 

EQUIVALENCE ( I lU , IPAR(l) ) , (lOU, IPAR(2) ) , (IPUl ,IPAR(3) ) S3500790 

. , (IPU2,IPAR(4)) , (IPU3,IPAR(5)) S3500800 

EQUIVALENCE (MAXDEP .GRVSET) , (IFRMT(l) ,IFRMT1) S3500810 

S3500820 

C *** END OF COMMON AREA ****83500830 

83500840 

^ 83500850 

DIMENSION RANGE(30,6) ,BEARNG(30,6) ,SIGYBR(30,6) ,CORSG(30,6) 83500860 

. »RCORSG(6) ,BCORSG(6) jXCORSG (6) 83500870 

C EQUIVALENCE STATEMENTS <58500880 

EQUIVALENCE 83500890 

. (PLUS, RANGE), (PLUS(181),BEARNG),(PLUS(361),SIGYBR) 83500900 

. , (PLUS(541) ,XC0RSG) , (PLUS (547 ) ,CORSG) , (PLUS (727 ) ,RCORSG) S3500910 

. , (PLUS(733) jBCORSG) 83500920 

9001 FORMAT (F8.1) S3500930 

DIMENSION LAB(l) ,X(2),Y(2),JNDVAR(4,5),IPSURX(4) S3500940 

. ,ISURX(99),SURX(57) S3500950 

EQUIVALENCE (JNDVRl , JNDVAR(1 , 2) ) , (JNDVR2, JNDVAR(1 , 3) ) 83500960 

,(JNDVR3,JNDVAR(1,4)),(JNDVR4,JNDVAR(1,5)) 83500970 

,(JNDVR0,JNDVAR(1,D) S3500980 

DATA IPSURX/44, 17,4,1/ S3500990 

DATA SURX/130. , 150. , 160. , 170, , 180. , 190. ,200. ,210. ,220. ,230. 83501000 

. .240. ,250. ,260. ,270. ,280. ,290. ,300. ,310. ,320. ,330. S3501010 

. .340. ,350. ,360. ,370. ,380. ,390. ,400. ,410. ,420. ,430. S3501020 
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,440. ,450. ,460. ,470. ,480. ,490. ,500. ,510. ,520 
,540. ,550. ,560. ,570. ,580. ,590. ,600. ,610. ,620 
,640. ,650. ,660. ,670. ,680. ,690. ,700./ 

DATA ISURX/ 1,1, 55, 6, 1,8, 10, 17, 19,26,28,35,37,44,46,55 
,12,1,4,5,8,10,13,14,17,19,22,23,26.28,31,32 
,37,40,44,45,47,48,51,55 
,28,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, 
,19,20,21,22,23,24,25.26,27,28,29,30,31.32, 
,37,38,39,40,41,42,43,44,45,46,47,48,49,50, 

,54,55,56/ 

IF(JND.EQ. 1) GO TO 30 

Y(l) = ALT(JND) * 0.08 + 90.0 

IF (ALT(JND) .GE. 3600.0) GO TO 30 

Y(2) = Y(l) 

IST=IPSURX(3+NL-NLINE) 

NDASH=ISURX(IST) 

NIMC=1 

IF(GOOD.GT.O) GO TO 10 

NDASH=28 

IST=44 

NINC=7 

0 DO 20 ND=1 ,NDASH,NINC 
ND2=2*ND 
ND2M1=ND2-1 

X(1)=SURX(ISURX(IST+ND2M1)) 

X(2)=SURX(ISURX(IST+ND2)) 

CALL PLOTQ(X,Y,2,0) 

0 CONTINUE 

0 IF((GOOD.GT.O.AND. JND.GT. 1) .OR. (GOOD. EQ.O. AND. JND.EQ 
RETURN 
0 CALL CODE 

WRITE (JNDVR0,9001) ALT(JND) 

YLABEL=TEMP ( JND ) - 2 7 3 . 1 5 
CALL CODE 

WRITE (JNDVRl ,9001) YLABEL 
YLABEL = PTEMP(JND) - 273.15 
CALL CODE 

WRITE (JNDVR2.9001) YLABEL 
CALL CODE 

TOITE (JNDVR3,9001) SPEED (JND) 

CALL CODE 

WRITE (JNDVR4,9001) DIR (JND) 

YLABEL = 435.0 
DO 50 1=1,5 

CALL CH ARQ ( XPR, YL ABEL, 0.JNDVAR( 1,1) ,8,2,1) 

50 YLABEL = YLABEL - 10.0 
RETURN 
END 


,530. 

,630. 


,35 


17,18 

33,34,35,36 

51.52,53,54 


.1)) GO TO 40 
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o n 


c 

c 

SUBROUT I NE CHARQ (XA , YA , IHT , I ARRAY , LEN , ITH , IPRAM) 

. , UPDATE; 8213 SOURCE: 02 FEB 79 LOCATION: KSC 

DIMENSION lARFAY(l) ,JARRAY(129) ,HT(4) ,THETA(4) 
EQUIVALENCE (JARRAY, JRRAYl) 

DATA HT/. 07,. 09,. 14,. 18/, THETA/180.,270.,0., 90./ 
LEN=MIN0(LEN,256) 

JRRAYl =LEN 
JTH=MIN0(ITH+1,4) 

JHT=MIN0(IHT+1,4) . 

X=.01*XA 
Y=.01*YA 
NWORDS=(LEN+l)/2 
DO 10 I=l,NWORDS 
JARRAY ( I + 1 ) = I ARRAY ( I ) 

10 CONTINUE 

CALL SYMB(X,Y,HT(JHT) , JARRAY, THETA (JTH) , IPRAM) 

RETURN 

END 


S3600000 

S3600010 

S3600020 

S3600030 

S3600040 

S3600050 

S3600060 

S3600070 

S3600080 

S3600090 

S3600100 

S3600110 

S3600120 

S3600130 

S3600140 

S3600150 

S3600160 

S3600170 

S3600180 

S3600190 

S3600200 

S3600210 

S3600220 


146 


SUBROUTINE PLOTQ (X , Y , LEN , JSW) 

. , UPDATE: 8213 SOURCE: 16 DEC 81 LOCATION: KSC 

DIMENSION X(1),Y(1) 

C PLOTS SOLID OR DASHED LINES 

C 

C 

LSW = 3 
DO 70 J=1,LEN 
■■ XP = X(J)*.01 

YP = Y(J)*.01 

: IF (JSW .EQ. 0) GO TO 10 

i IF (LSW .EQ. 2) GO TO 20 

DLST =0.0 

i XLST = XP 

YLST = YP 
LST = 1 
L = 2 

I 10 CALL PLOT (XP,YP, LSW) 

; GO TO 70 

i 20 DX = XP-XLST 

DY = YP-YLST 

DR = SQRT(DX*DX+DY*DY) 

TH = ATAN2(DY,DX) 

CSS = COS(TH) 

; SSS = SIN(TH) 

, 30 DINC = .05 

, 40 DINC = DINC-DLST 

IF (DINC .LE. DR) GO TO 50 
DINC = DR 
DLST = DLST+DINC 
GO TO 60 

I 50 DLST =0.0 

i 60 XN = XLST+DINC*CSS 

YN = YLST+DINC*SSS 

I LTSW = 2 

i IF (MOD (LST, 2) .EQ. 0) LTSW = 3 

CALL PLOT (XN,YN, LTSW) 

I XLST = XN 

i YLST = YN 

I DR = DR-DINC 

I IF (DLST .GT. 0.0) GO TO 70 

LST = LST+1 

i IF (LST .GT. L) LST = 1 

IF (DR .GT. 0.0) GO TO 30 
70 LSW = 2 

CALL PLOT(.01*X(LEN),.01*Y(LEN),3) 

RETURN 

END 
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n n 


REEDM SOURCE MODULE &RDHMM 


FTM4 

PROGRAM RDH>IM(5) 

. , UPDATE; 8213 SOURCE 


02 APR 82 LOCATION 


KSC 


ORGANIZATION: H. E. CRAMER CO., INC. 

WORK FOR: DR. J. B. STEPHENS (ES84) 

PROGRAM CODE: RDHMM 

PROGRAM DESCRIPTION: ONE OF THE MODULES FOR ROCKET EXHAUST 

EFFLUENT DIFFUSION ANALYSIS (MULTI-LAYER) 

INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS 

OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS, PLOTS 


Q ********************** A****:*:*******************:^***** ******** 

c * * 

C * PROGRAM RDHMM - READS BOTTOM AND MIXING LAYER HEIGHT * 
C * * 

Q ************************************************************* 

Cc 

c**** BEGIN COMMON AREA 


S38000C0 
S3800010 
S3800020 
S3800030 
S3800040 
S3800050 
S3800060 
S38C0070 
S3800080 
S3800090 
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S3800130 
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S3800210 
S3800220 
S3800230 
S3800240 
S3800250 
S3800260 
S3800270 
****S3800280 


04/02/82 

math parameters and CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAlffiDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN,MODEL, IVHICL,NORMAL,TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV, I SIG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR, SIGMER, LSITE , BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE (3) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(lO) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

. MODEL4,MODEL5,MODEL6 

INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 
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SIGZ.ISNDFO, CRT, LAYT0P(3),ITDU, KEEP S3800500 

.MIXING , MAXDEP ,LAYBOT(3) S3800510 

, ALTSV, BATCH, CL(14),CS(10) .GASSET, lAGAIN, • S3800520 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , S3800530 

MINUS 1.MINUS9, MINS 1.MINS9, S3800540 

MOD EL4 .MODELS, MOD EL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , S3800550 

RT(24) .TPROPC.IDXRT S3800560 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S3800570 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S3800580 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S3800590 

CLRLNE.INSLNE, DELINE S3800600 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) , INV(2) ,INVHF(2) , S3800610 

INVNDR(2) ,ULINE(2), S3800620 

. TAB , TAB 2 , S ETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDS P ,S3800630 

CLRLNE.INSLNE, DELINE, S3800640 

IESCAJO) .NULL.IBLNK, . S3800650 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,IN6j,NAMEP(3) S3800660 

C VEHICLE PARAMETERS S3800670 

COMMON /VCLPR/ VPAR(17) S3800680 

C TIME PAPvAMETERS S3800690 

COMMON /TIME/ JTIME, JDAY , JYEAR, ISTIME, ISDAY , ISYEAR.LTIME , S3800700 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S3800710 

C SOUNDING /FORC AST METEOROLOGICAL DATA (INITIAL LEVELS) S3800720 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S3800730 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S3800740 

C LAYER PARAMETERS S3800750 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,(^29) ,RISTIM(29) ,SIGXO(29) , S3800760 

SIGYO(29) S3800770 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S3800780 

COMMON /BLAYR/ DIRB (6) , SPEEDB (6) , TEMPB (6) S3800790 

C CALCULATED NEW LAYER PARAMETERS S3800800 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S3800810 
SPEEDN(32) S3800820 

C CONVERSION FACTORS S3800830 

COMMON /CNVRT/ QCONV(4) .QPDEPH S3800840 

C S3800850 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S3800860 
COMMON /EXTRA/ NCOM(l), NTOTAL(l) , PLUS(900) S3800870 

C READ/WRITE BUFFER S3800880 

Q A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S3800890 

C**5V********************************************************************S3800900 
C S3800910 

C EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(D) , (lOU, IPAR(2) ) , (IPU1,IPAR(3)) 
,(IPU2,IPAR(4)),(IPU3,IPAR(5)) ' 

EQUIVALENCE (MAXDEP .GRVSET) , (IFRMT(l) .IFRMTl) 


END OF COMMON AREA 


C**** 

Cc 

CF INPUT FORMAT STATEMENTS 

9001 FORMAT (73H *** REEDM WARNING 019, -1 NOT APPLICABLE, PROG. ABORTSS3801000 
* IF -1 TYPED AGAIN/) S3801010 
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S3800930 
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S3800960 

****S3800970 

S3800980 

S3800990 
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9002 FORMAT(A2) S3801020 

9003 FORNAT(12) S3801030 

9004 FORMAT (2A2,38H *** REFDM ERROR 001, DATA INPUT ERROR, 2A2.6H REF. S3801040 

*,I2,IH, ,11/) S3801050 

9005 FOR>1AT(50H DO YOU WISH TO PLOT THE METEOROLOGICAL PROFILE? (,2A2, S3801060 

*1HY,2A2,2HES,2A2,1H, ,2A2,1HN,2A2,4H0):_) S3801070 

9006 FORMAT(3A2) _ S3801080 

9007 FORMAT(15H HEIGHT AT THE ,2A2,8H OF THE , 3A2 , 15HLAYER (METERS) : ,9X83801090 

*.F8.2) S3801100 

9008 FORMAT(24H DO YOU WISH TO CHANGE ( , 2A2 , IHN, 2A2 ,6HEITHER, 2A2 , IH, , S3801110 

*2A2,1HU,2A2,5HPPER,,2A2,1HL,2A2,25H0WER) TRANSITION LAYER? :_) S3801120 

9009 FORMAT(24H DO YOU WISH TO CHANGE ( , 2A2 , 1HT,2A2 ,2HOP , 2A2 , IH, , 2A2 , S3801130 

*1HB,2A2,33HASE) HEIGHT OF THE UPPER LAYER? :_) S3801140 

9010 FORMAT ( 2 5H ENTER THE HEIGHT AT THE ,2A2,8H OF THE ,3A2,17H LAYER (S3801150 

*METERS):_) S3801160 

9011 FORMAT(69H *** REEDM WARNING 020, INVALID LAYERING - SPACE RETURN S3801170 

*TO CONTINUE:_) S3801180 

9012 FORMAT (2A2,18H ENTER SIGMA AZ, (,2A2, 1HE,2A2,9HSTIMATED=,2A2, S3801190 

*F5.2,2A2,1H,,2A2,1HA,2A2,9HN0THER):_) ■ S3801200 

9013 FORMAT (2A2, 2 3H ENTER SIGMA AZ (DEG) :_) S3801210 

9014 FORMAT(2A2,20H SIGMA AZ (DEGREES) : ,45X,F5. 2) S3801220 

9015 FORMAT(57H DO YOU WISH TO INPUT SIGMA A & SIGMA E FOR EACH LEVEL? S3801230 

* ( , 2A2 , IHN , 2A2 , IHO , 2A2 , IH, , 2A2 , IHY, 2A2 , 5HES) :_) S380 1240 

9016 FORMAT(18H ENTER SIGMA EL, ( , 2A2 , 1HE,2A2 ,9HSTIMATED= ,2A2 ,F5 . 2 S3801250 

*,2A2, IH, ,2A2,1HA,2A2,9HN0THER) :_) S3801260 

9017 FORMAT(2A2,23H ENTER SIGMA E% (DEG) :_) S3801270 

9018 FORMAT ( 2 A2, 2 OH SIGMA EL (DEQUES) : ,45X,F5. 2) S3801280 

9019 FORMAT(43H ENTER SIGMA A, SIGMA E (IN DEG) FOR LEVEL ,I2,2H (, S3801290 

*F6.3,1H, ,F6.3,3H) :_) S3801300 

9020 FORMAT (2A2, 2 7H SIGMA A, SIGMA E FOR LEVEL , 12, IH: , 33X, 2F6. 2) S3801310 

9021 FORMAT(69H *** REEDM WARNING 021, TOP OF UPPER LAYER LESS THAN T0PS3801320 

* OF SOUNDING, /12H CONTINUE? ( , 2A2 , IHN, 2A2, IHO, 2A2, IH, , 2A2 , IHY, 2A2 , S3801330 
*5HES):_) S3801340 

9022 FORMAT (68H *** REEDM WARNING 022, GAP BETWEEN LAYERS MAY NOT PR0DUS3801350 
*CE REALISTIC/44H GRAVITATIONAL SETTLING RESULTS, CONTINUE? (,2A2, S3801360 


*1HN,2A2,1H0,2A2,1H, ,2A2,1HY,2A2,5HES) 

CF OUTPUT FORMAT STATEMENTS, 

9023 FORMAT (2A2,A1) 


) 


type AND DIMENSION STATEMENTS 

LOGICAL IBATCH,DONE(2) 

INTEGER UPPER(3) ,LOWER(3) ,BASE(2) ,TOP(2) ,FMTHT1 (25) ,FMTHT2(25) 
DIMENSION HEIGHT(2) ,IPFMT(2) 


EQUIVALENCE (PLUS (740) , IBATCH) , (PLUS(738) , HEIGHT) , 

1 (PLUS (737 ),IPFMT), (PLUS (736) , IIUTMP) , 

2 (PLUS (735) , LOOP) , (PLUS (734) , IPLOT) 

C DATA STATEMENTS 

DATA FMTHTl /2H(8,2H(2,2HH , 2H+) , 2H, " , 2H C, 2HAL, 2HCU, 2HLA, 2HTI , 

1 2HON,2H H,2HEI,2HGH,2HT",2H,7,2H(2,2HH ,2H+),2H,8, 

2 2HX, ,2HF8,2H.2,2H) ,2H / 

DATA FMTIIT2 /2H(7 , 2H(2 , 2HH , 2H+) , 2H," , 2H S , 2HTA, 2HBI , 2HLI , 2HZA, 
1 2HTI,2HON,2H H,2HEI,2HGH,2HT",2H,7,2H(2,2HH ,2H+), 
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no n n 


2 2H,8,2HX, ,2HF8,2H.2,2H) / 

DATA UPPER/211UP,2HPE, IHR/ 

DATA LOWER/ 2HL0 , 2HWE , IHR/ 

DATA BASE/2HBA,2HSE/ 

DATA TOP/2IITO,2HP / 

DATA IHF/ IHF/ , IHU/ IHU/ , IHL/ IHL/ , IHB/ IHB/ , IHT/ IHT/ , IHA/ IHA/ , 
*IHE/1HE/ 

DATA IIHAN/2HAN/ , IIHES/2HES/ , IIHNE/2HNE/ 

DATA IESA/15501B/,IESD/15504B/,IESJ/15512B/ 

DATA JVERSM/8213/ 


IF (IVERSN .NE. JVERSN) CALL L0ADS(-1 ,0,0, 0,0, BATCH) 

IF (CRT) GO TO 10 
I ESA = NULL 
lESD = NULL 
lESJ =.NULL 
10 CONTINUE 

DETERMINE SEGMENT ENTRY POINT. 

GOTO (20,130,460), NNNTRY 
20 CONTINUE 

IBATCH = .FALSE. 

C 

IF(KEEP.EQ. 1) GO TO 40 

C— BEGIll PROCESSING 

IFdCALC.EO. 1) CALHT=0.0 
IFdCALC.EQ.2) CALHT=H 

C DEFAULT MIXING HEIGHT TO TWICE THE STABILIZATION HEIGHT. 
HM(1) = H + H 
ISF=1 

INDX=IHIDX(ALT,NUM,HM(1) ,ISF) 

HM(1)=ALT(INDX+1) 

HM(2)=0.0 
BOTLAY=0.0 
LAYBOT(l)=l 
LAYTOP(l)=INDX 
LAYBOT(2)= 1 
LAYTOP(2)= 0 
LAYBOTO) = 1 
LAYTOP(3) =0 

IF(INDX+1 .EQ. NUM) GOTO 40 


C FOR HM(1) § ALT (NUM) SET TOP OF SECOND 

C BOUNDARY LAYER TO TOP OF MET SOUNDING. 


HM(2) = ALT (NUM) 
LAYTOP(2) = NUM - 1 
IF (MODEL .NE. 6) GOTO 30 
LAYBOT(2) = 1 
GOTO 40 

30 LAYBOT(2) = INDX + 1 
BOTLAY = HM(1) 

40 CONTINUE 
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c 

c 

c 


INITIALIZE CALCULATION & STABILIZATION RELATIONSHIPS. 

HEIGHT (1) = CALHT 

HEIGHT (2) = H 

IF(H .GT. CALHT) GOTO 50 

IPFMT(l) = 1 

IPFMT(2) = 2 

GOTO 60 

50 IPFMT(l) = 2 
IPFMT(2) =1 
60 CONTINUE 
JER = 0 

PLOT METEOROLOGICAL PROFILE 

IPL0T=1 

G00D=0 

IF (.NOT. BATCH) GOTO 70 
READ(IIU,9002) INPT 
IPLOT = 2 

IFCINPT .EQ. INJ .OR. INPT .EQ. INOJ) GOTO 130 
IPLOT = 1 
N = 2 

IFCINPT .EQ. IHF) N = 1 
GOTO 120 

70 WRITE(ICU,9005) INVNDR, INV, OFF,ULINE,OFF 
INPT = IBLNK ■ 

READ(IIU,9002) INPT 
N = 1 

IFdNPT.EQ.INJ .OR. INPT. EQ. INOJ) GO TO 90 
IFdNPT .EQ. MINUS9) GO TO 900 
IFCINPT .NE. MINUSl) GO TO 80 
JER = JER+1 

IF (JER .GT. 1) GO TO 890 
IJRITE (ICU,9001) 

GO TO 70 

80 IF (INPT .EQ. IBLNK. OR. INPT. EQ.IYSJ. OR. INPT. EQ.IYESJ) GO TO 100 
WRITE (ICU.9004) INV, OFF, 17,0 
GO TO 70 
90 IPLOT = 2 
100 JER = 0 

WRITE(ICU,9006) lESA, lESD, lESJ 
110 GO TO (120,130) IPLOT 
120 GO0D=0 

NNNEST = 4 
NNNTRY = N 
LLNEST = 3 
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LLNTRY = 2 S3802500 

CALL REEDM S3802510 

DISPLAY BOUNDARY LAYERS VALUES. MUCH OF THE LOGIC DETERMINES S3802520 

WHEN TO DISPLAY THE CALCULATION & STABILIZATION HEIGHTS. S3802530 

S3802540 


130 CONTINUE S3802550 

IF(. NOT. BATCH .OR. IBATCH) GOTO 150 S3802560 

READ(IIU,9002) I S3802570 
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IF(I .EQ. lYSJ.OR. I .EO.IYESJ) GOTO 140 
GO TO 460 

C GOTO (450,460), IPLOT 
140 IBATCII = .TRUE. 

IIUTMP = IIU 
IIU = ICU 

150 DONE(l) = .FALSE. 

D0NE(2) = .FALSE. 

L00P=0 

DO 160 I = 1,2 
II = IPFMT(I) 

IF(HM(2) .EQ.O.O.OR.HEIGHT(Il) .LT.HM(2)) GO TO 160 
IFUl.EQ.l) URITE(ICU,FMTHT1) HEIGHT(l) 

IF(I1.EQ.2) WRITE ( ICU, FMTHT2) HEIGHT(2) 

L00P=L00P+1 
DONE(Il) = .TRUE. 

160 CONTINUE 

IF(HM(2) .EQ.0.0) GO TO 170 
URITEUCU,9007) T0P,UPPER,HM(2) 

L00P=L00P+1 
170 DO 180 I = 1,2 
II = IPFMT(I) 

IF(BOTLAY.EQ.O.O.OR.HEIGHT(I1) .LT.BOTLAY.OR.DONE(Il)) GO TO 180 
IF(Il.EQ.l) WRITE (ICU, FMTHTl) HEIGHT(l) 

IFUl.EQ.2) VJRITE(ICU,FMTHT2) HEIGHT(2) 

L00P=L00P+1 
DONE (II) = .TRUE. 

180 CONTINUE 

IF( (MODEL .NE. 6 .AND. BOTLAY .EQ. 0.0) .OR. 

1 (MODEL .EQ. 6 .AND. HM(2) .EQ. 0.0)) GOTO 190 
WRITE ( ICU , 900 7 ) BASE , UPPER , BOTLAY 
LOOP=LOOP+ 1 
190 DO 200 I = 1,2 
II = IPFMT(I) 

IF(HEIGHT(I1) .LT.HM(l) .OR.DONE(Il)) GO TO 200 
IF(Il.EQ.l) WRITE (ICU, FMTHTl) HEIGHT(l) 

IF(I1.EQ.2) WRITE (ICU, FMTHT2) HEIGHT(2) 

LOOP=LOOP+l 
DONE(Il) = .TRUE. 

200 CONTINUE 

WRITE(ICU,9007) TOP, LOWER, HM(1) 

LOOP=LOOP+1 
DO 210 I = 1,2 
II = IPFMT(I) 

IF(D0NE(I1)) CO TO 210 

IF(Il.EQ.l) WRITE(ICU, FMTHTl) HEIGHT(l) 

IF(I1.EQ.2) WRITE (ICU, FMTHT2) HEIGHT(2) 

LOOP=LOOP+l 
DONE(Il) = .TRUE. 

210 CONTINUE 

WRITE ( ICU , 9007 ) BASE , LOWER , ALT ( 1 ) 

LOOP=LOOP+l 
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ENTER BOUNDARY LAYERS OPTIONS. 

220 ^>miTE(ICU,9008) INVNDR, INV,OFF,ULINE,OFF,LtLINE,OFF 
L00P=L00P+1 
INPT = IBLNK 
READ(IIU,9002) INPT 
IF(INPT .NE. MINUSl) GOTO 230 
INPT = -2 
GOTO 420 

230 IF(. NOT. BATCH .AND. INPT. EQ.MINUS9) GO TO 900 

IF (INPT. EQ.IBLinC. OR. INPT. EQ.INJ. OR. INPT. EQ.IIHNE) GO TO 460 
IF (INPT .EQ. IHU.OR.INPT .EQ. UPPER(l)) CO TO 240 
IF (INPT .EQ. IHL.OR.INPT .EQ. LOWER(l)) GO TO 270 
IF (BATCH) GO TO 460 
TOITE (ICU,9004) INV, OFF, 18,0 
LOOP = LOOP-1 
GO TO 220 
240 I = 3 

IF (MODEL .EQ. 6) GOTO 280 
250 WRITE (ICU, 9009) INVNDR, INV, OFF, ULINE, OFF 
LOOP=LOOP+l 
INPT = IBLNK 
READ(IIU,9002) INPT 
IF (INPT .EQ. MINUSl) GOTO 410 
IF(. NOT. BATCH .AND. INPT. EQ.MINUS9) GO TO 900 
IFdNPT.EQ.IHB.OR.INPT .EQ.BASE(l)) GO TO 260 
IF (INPT. EQ. IBLNK. OR. INPT. EQ.IHT. OR. INPT. EQ.TOP(D) GO TO 280 
WRITE (ICU, 9004) INV, OFF, 18,2 
LOOP = LOOP-1 
GO TO 250 
260 I = 2 

GO TO 280 
270 1=1 

280 GO TO (290,330,370) I 
290 WRITE (ICU, 90 10) TOP, LOWER 
LOOP=LOOP+l 

CALL IFNRR(IFRMT,14,IER,IIU) 

IF (BATCH .OR. lER .EQ. 0) GO TO 310 
300 WRITE (ICU, 9004) INV, OFF, 18,1 
LOOP = LOOP-1 
GO TO 280 
310 A1 = 0.0 

CALL CODE (80) 

READ (IFRMT,*) A1 

TF(BATCH .AND. A1 .LT. -1.0) A1 = -1.0 
IF (A1 .EQ. MINSl) GO TO 410 
IF (A1 .EQ. MINS9) GO TO 900 
IF (A1 .GE. 0.0) GO TO 320 
GO TO 300 
320 ISF=1 

INDX=IHIDX(ALT,NUM,A1 ,ISF) 
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HM(1)=ALT(INDX+1) 

LAYT0P(1)=INDX 
GO TO 420 

C ENTER BOTLAY - BASE OF UPPER LAYER. 

330 WRITE(ICU,9010) BASE, UPPER 
L00P=L00P+1 

CALL IFNBR(IFRMT,14,IER,IIU) 

IF (BATCH ,0R. lER .EQ.- 0) GO TO 350 
340 TOITE (ICU,9004) INV, OFF, 18,3 
LOOP = LOOP-1 
GO TO 280 
350 A1 = 0.0 

CALL CODE (80) 

READ (IFRMT,*) A1 

IF(BATCH .AND. A1 .LT. -1.0) A1 = -1.0 
IF (A1 .EQ. MINSl) GO TO 410 
IF (A1 .EQ. MINS9) GO TO 900 
IF (A1 .GE. 0.0) GO TO 360 
GO TO 340 
360 ISF=0 

INDX=IHIDX (ALT , MUM, A1 , ISF) 
BOTLAY=ALT(INDX) 

LAYBOT(2)=INDX 
GO TO 420 

370 WRITE (ICU, 9010) TOP, UPPER 
L00P=L00P+1 

CALL IFMBR(IFRMT,14,IER,IIU) 

IF (BATCH .OR. lER .EQ. 0) GO TO 390 
380 WRITE (ICU, 9004) INV, OFF, 18,4 
LOOP = LOOP-1 
GO TO 280 
390 A1 = 0.0 

CALL CODE (80) 

READ (IFRMT,*) A1 

IF(BATCH .AND. A1 .LT. -1.0) A1 - -1.0 
IF (A1 .EQ. MINSl) GO TO 410 
IF (A1 .EQ. MINS9) GO TO 900 
IF (A1 .GE. 0.0) GO TO 400 
GO TO 380 
400 ISF=1 

INDX=IHIDX(ALT,NUM,A1 , ISF) 
HM(2)=ALT(INDX+1) 

LAYTOP(2)=INDX 
GOTO 420 
410 INPT = MINSl 
420 DO 430 1=1, LOOP 

WRITE(ICU,9006) lESA, lESD, lESJ 
430 CONTINUE 

IF(BATCH .AND. INPT .LT. -1) INPT = -1 
IF(INPT+1) 40,130,440 
440 GO TO (450,130) IPLOT 
450 GOOD=-l 
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NNNEST = 4 
NNNTRY = 2 
LLNEST = 3 
LLNTRY = 2 
CALL REEDM 
460 1=0 

IF(MODEL .NE. 6) GOTO 490 

IF(H>I(2) .EQ. 0.0 .AND. HM(1) .GT. 0.0) I = 1 

IF(HM(2) .GT.0.0 .AND. HM(2) .GT.HM(l) .AND. HM(1) .GT.0.0) 1=2 

IF(I) 550,550,470 

470 IF(LAYTOP(I)-(NUM-l)) 480,570,570 
480 WRITE(ICU,9021) INVNDR, INV,OFF,ULINE,OFF 
INPT = IBLNK 
READ(IIU,9002) INPT 

IF(. NOT. BATCH .AND. INPT .EQ. MINUS9) GOTO 900 
\JRITE(ICU,9023) lESCAJ 

IF(INPT .EQ. lYSJ.OR. INPT .EQ.IYESJ) GOTO 570 
IF (INPT. EQ. IBLNK. OR. INPT. EQ.INJ. OR. INPT. EQ.INOJ) GO TO 420 
WRITE (ICU,9004) INV,OFF,0,0 
GO TO 480 
490 CONTINUE 

IF(HM(2) .EQ. 0.0. AND. BOTLAY.EQ. 0.0. AND. HM(1). GT.0.0) 1=1 
IF(HM(2).GT.BOTLAY.AND.BOTLAY.EQ.HM(1) .AND.HM(l).GT.O.O) 1=2 
IF(HM(2) .GT.BOTLAY. AND. BOTLAY.GT.HM(l). AND. HM(1). GT.0.0) 1=3 
IF (MODEL .EQ. 5) GOTO 540 
IF(I.EQ.l.AND.CALHT.LT.HMd)) GO TO 560 
IF(I.EQ.2.AND.CALHT.LT.HM(2)) GO TO 560 
IF(I-3) 550,500,550 

500 IF(CALHT.LT.HM(2) .AND.CALHT.GE.BOTLAY) GO TO 510 
IF(CALHT.LT.HMd)) GO TO 510 
GOTO 550 

510 DO 520 J = 1,4 

IF(IPLLNT(J)-4) 520,530,520 
520 CONTINUE 
GOTO 560 

530 WRITE(ICU,9022) INVNDR, INV, OFF, ULINE, OFF 
INPT = IBLNK 
READ(IIU,9002) INPT 

IF (.NOT. BATCH .AND. INPT .EQ. MINUS9) GOTO 900 

WRITE(ICU,9023) lESCAJ , lESCAJ 

IF (INPT .EQ. lYSJ.OR. INPT .EQ.IYESJ) GOTO 560 

IF (INPT. EQ. IBLNK. OR. INPT. EQ.INJ. OR. IBLNK. EQ.INOJ) GO TO 420 

WRITE (ICU,9004) INV, OFF, 0,0 

GO TO 530 

540 IF(I .EQ. 1 .OR. I .EQ. 2) GOTO 560 

C INVALID LAYERING - REENTER LAYERS. 

550 WRITE (ICU,9011) 

LOOP=LOOP+l 
INPT = IBLNK 
READ(IIU,9002) INPT 

IF (.NOT. BATCH .AND. INPT .EQ. MINUS9) GOTO 890 
GO TO 420 
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560 IF(.NOT.MA:{DEP.OR.MODEL.NE.4.0R.LAYTOP(1)+1.EQ.NUM) goto 570 


c SETUP "HIDDEN" BOUNDARY LAYER FOR MODEL 4 

C GRAVITATIONAL SETTLING. 


IF(CALHT .LT. HM(1)) NBK = 2 

IF(I.NE.l .AND. CALHT.GE.HM(l) .AND. LAYTOP(2) .NE.NUM) NBK = 3 
LAYBOT(NBK) = LAYBOT(NBK-l) 

LAYTOP(NBK) = NUM - 1 
GOTO 580 

C VALID LAYERING - CONTINUE 

570 CONTINUE 
NBK=1 

IF(I.EQ.2.0R.I.EQ.3) NBK=2 
580 CONTINUE 

IF(lPLOT .EQ. 1) GOOD = 1 
IF^BATCH) IIU = IIUTMP 
IBATCH = .FALSE. 

ENTER SIGMA (A) AND SIGMA (E) 

IF (.NOT. BATCH) GOTO 590 
READ(IIU,9002) I 

IF(I .NE. IHA.AND.I .NE. IIHAN) GOTO 670 
IBATCH = .TRUE. 

IIUTMP = IIU 
IIU = ICU 

590 WRITE(ICU,9012) IESA,IESJ,ULINE,OFF,INV,SIGMAR,OFF,ULINE,OFF 
INPT = IBLNK 
READ(IIU,9002) INPT 
IF (BATCH) GOTO 600 
IFUNPT .EQ. MINUS9) GOTO 900 
IFaNPT .EQ. MINUS 1) GOTO 410 

600 IF (INPT. EQ. IBLNK. OR. INPT. EQ.IHE. OR. INPT. EQ.IIHES) GO TO 660 
IF UNPT.EQ.IHA. OR. INPT. EQ. IIHAN) GO TO 610 
IF (BATCH) GO TO 660 
WRITE (ICU, 9004) INV, OFF, 19,0 
GO TO 590 

610 WRITE (ICU, 90 13) IESA,IESJ 
RNPT =0.0 

CALL IFNBRdFRMT, 14,IER,IIU) 

IF (BATCH .OR. lER .EQ. 0) GO TO 630 
620 WRITE (ICU, 9004) INV, OFF, 19,1 
GO TO 610 
630 CALL CODE (80) 

READ (IFRMT,*) RNPT 
IF (BATCH) GO TO 650 
IF (RNPT .EQ. MlNSl) GO TO 640 
IF (RNPT .EQ. MINS9) GO TO 900 
IF (RNPT .GT. 0.0) GO TO 650 
GO TO 620 

640 WRITE (ICU, 9023) lESCAJ 
GOTO 580 

650 IF(RNPT.GT.O.O) SIGMAR=RNPT 
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660 V7RITE(ICU,9014) lESA, lESJ, SIGMAR 
670 CONTINUE 

SIGNER = SIGMAR 
IF(IBATCH) IIU = IIUTMP 
IBATCH = .FALSE. 

IF (.NOT. BATCH) GOTO 680 
READ(IIU,9002) I 

IF (I .NE. IHA.AND.'I .NE. I IRAN) GOTO 880 
IBATCH = .TRUE. 

IIUTMP = IIU 
IIU = ICU 

680 WRITE(ICU,9016) ULINE, OFF, INV, SIGNER, OFF, ULINE, OFF 
INPT = IBLNK 
READ(IIU,9002) INPT 
IF(BATCH) GOTO 690 
IF(INPT .EQ. NINUS9) GOTO 900 
IF(INPT .NE. MINUSl) GOTO 690 
WRITE(ICU,9023) lESCAJ 
GOTO 580 

690 IF (INPT. EQ. IBLNK. OR. INPT. EQ.IHE. OR. INPT. EQ.IIHES) GO TO 750 
IF (INPT.EQ.IHA.OR.INPT.EQ.IIHAN) GO TO 700 
IF (BATCH) GO TO 750 
TOITE (ICU, 9004) INV, OFF, 20,0 
GO TO 680 ' 

700 WRITE(ICU,9017) lESA.IESJ 
RNPT = 0.0 

CALL IFNBR(IFRMT,14,IER,IIU) 

IF (BATCH .OR. lER .EQ. 0) GO TO 720 
710 WRITE (ICU, 9004) INV, OFF, 20,1 
GO TO 700 
720 CALL CODE (80) 

READ (IFRNT,*) RNPT 
IF (BATCH) GOTO 740 
IF (RNPT .EQ. MINSl) GO TO 730 
IF (RNPT .EQ. NINS9) GO TO 900 
IF (RNPT .GT. 0.0) GO TO 740 
GO TO 710 

730 WRITE(ICU,9023) lESCAJ 
GOTO 670 

740 IF(RNPT.GT.O.O) SIGMER=RNPT 
750 WRITE(ICU,9018) IESA,IESJ, SIGNER 
IF (IBATCH) IIU = IIUTMP 


IF(IRUN .LT. 3) GOTO 880 
760 ISIG = 0 

WRITE ( ICU , 90 1 5 ) INVNDR , INV , OFF , ULINE , OFF 

INPT = IBLNK 

READ( IIU, 9002) INPT 

IFdNPT .EQ. MINUS9) GOTO 900 
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IFdJIPT .NE. MINUSl) GOTO 770 


S3805700 



WRITE(ICU,9023) lESCAJ.IESCAJ 


S3805710 



GOTO 670 
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770 

UTIITE(ICU,9006) lESA, lESD, lESJ 


S3805730 



IF (INPT. EQ. IBLNK. OR. INPT. EQ. INJ.OR. INPT 

.EQ.INOJ) GO TO 880 

S3805740 



IF (INPT. EQ.IYSJ. OR. INPT. EQ.IYESJ) GO TO 

780 

S3805750 



WRITE (ICU,9004) INV,0FF,20,2 
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GO TO 760 
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c 

SET USER-ENTERED SIGAP & SIGEP FLAG FOR 

ROUTINE TURB4 IN RCLDM. 

S3805780 


780 

ISIG =• 1 


S3805790 



1 = 2 
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790 

CONTINUE 
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IF (ALT(I) .EQ. HM(1)) GO TO 800 


S3805820 
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IF (ALT(I) .GT. HM(1)) GO TO 810 
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SIGAP(I) = SIGMAR 
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SIGEP (I) = SIGNER 
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GO TO 820 
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i 

800 

SIGAP(I) = SIGMAR*. 74074074 


S3805870 

1 


SIGEP(I) = SIGNER*. 74074074 


S3805880 

I 


GO TO 820 


S3805890 

1 

810 

SIGAP (I) = 1.0 


S3805900 

i 


SIGEP(I) = 1.0 


S3805910 

1 

820 

WRITE (ICU.9019) I.SIGAP(I) ,SIGEP(I) 


S3805920 

1 


CALL IFNBR(IFRMT,20,IER,IIU) 


S3805930 

i 

-i 


IF (BATCH .OR. lER .EQ. 0) GO TO 840 


S3805940 


830 

TOITE (ICU.9004) INV,OFF,20,3 


S3805950 

= 


GO TO 790 


S3805960 

3 

840 

RNPT =0,0 


S3805970 

1 


RNPTl =0.0 


S3805980 



CALL CODE (80) 


S3805990 



READ (IFRMT,*) RNPT, RNPTl 


S3806000 



IF (RNPT .EQ. MINSl) GO TO 850 


S3806010 

= 


IF (RNPT .EQ. MINS9) GO TO 900 


S3806020 

i 


IF (RNPT .GE. 0.0. AND. RNPTl .GE. 0.0) GO 

TO 870 

S3806030 

1 


GO TO 830 


S3806040 

1 

850 

WRITE(ICU,9023) lESCAJ.IESCAJ 


S3806050 

1 


IF(I-2) 760,760,860 


S3806060 

a 

860 

1=1-1 


S3806070 

"■ 


GO TO 790 


S3806080 

1 

870 

IF (RNPT .GT. 0.0) SIGAP(I) = RNPT 


S3806090 

“ 


IF (RNPTl. GT. 0.0) SIGEP(I) = RNPTl 


S3806100 

S 


TOITE(ICU,9020) IESA,IESJ,I,SIGAP(I) ,SIGEP(I) 

S3806110 

i 


1 = 1+1 


S3806120 

i 


IF(NUM-I) 880,790,790 


S3806130 

s 

880 

SIGEP (1)=SIGMER 


S3806140 

- 


SIGAP (1)=SIGMAR 


S3806150 



GOTO 910 


S3806160 


c 

ERROR EXIT. 


S3806170 


890 

lERROR(l) = MINSl 


S3806180 



GOTO 910 


S3806190 


900 

lERROR(l) = 1 


S3806200 


910 

KNNEST = 2 


S3806210 



159 





NMNTRY = 3 
CALL REEDM ' 
END 


S3806220 

S3806230 

S3806240 
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INTEGER FUNCTION IHIDX(Z ,N,VAR, II) S3900000 

. , UPDATE: 8213 SOURCE: 30 IIAR 79 LOCATION: KSC S3900010 

C S3900020 

DIMENSION Z(l) S3900030 

IF(VAR.LT.Z(D) VAR=Z(1) S3900040 

IF(VAR.GT.Z(N)) VAR=Z(N) S3900050 

DO 10 1=1, N-1 S3900060 

IF(VAR.GE.Zd) .AND.VAR.lt. Z(I+1)) GO TO 20 S3900070 

J=I+1 S3900080 

10 CONTINUE S3900090 

1=1-1 S3900100 

20 IF(II.EQ.1.AND.ABS(VAR-Z(I)).LT.ABS(Z(I+1)-VAR)) 1=1-1 S3900110 

IFdl.EQ.O.AND.ABS(VAR-Zd)) .GT.ABS(Z(I+1)-VAR)) 1=1+1 S3900120 

IHIDX=I S3900130 

RETURN S3900140 

END S3900150 
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REEDM SOURCE MODULE &RCONM 


etna SAOOOOOO 

PROGRAM! RCONM(5) S4000Q10 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC SA000020 

C; :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: : :SA000030 
C: : S4000040 
C::: : : : S4000050 

C::: : : : S4000060 

C::: ORGANIZATION: H. E, CRAMER CO., INC. :::S4000070 

C::: : : : S4000080 

C::; WORK FOR: DR. J. B. STEPHENS (ES84) : : : S4000090 

C::: . :::S4000100 

C::: PROGRAM CODE: RCONM :::S4000110 

C::: :::S4000120 

C::: PROGRAM DESCRIPTION: :::S4000130 

C::: THIS PROGRAM CALCULATES THE DOSAGE, CONCENTRATION, TIME MEAN :::S4000140 

C::: CONCENTRATION, AND MAXIMUM CENTERLINE CONCENTRATION FOR THE :::S4000150 

C::: MEAN WIND DIRECTION RADIAL AT EVERY 1000 METERS D0WN1^/IND FROM :::S4000160 

C::: THE LAUNCH SITE. :::S4000170 

C::: :::S4000180 

C: ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: : S4000190 
C: : S4000200 
C S4000210 

C S4000220 

Cc S4000230 

C**** BEGIN COMMON AREA ****S4000240 

04/02/82 S4000250 

MATH PARAMETERS AND CONSTANTS S4000260 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S4000270 

C INPUT OPTIONS S4000280 

REAL LAMBDA S4000290 

INTEGER FILE, GOOD, TITLE S4000300 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHI CL, NORMAL, TPROP, S4000310 

I SHAPE, GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S4000320 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S4000330 

IPLACE,IPRINT,SIGMAR, SIGNER, LSITE,BOTLAY, S4000340 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) S4000350 

,RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S4000360 

,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , S4000370 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , S4000380 

FS(20) ,MDLNAM(12) ,DBAR(20) S4000390 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S4000400 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S4000410 

MODEL4, MODELS, MODEL6 S4000420 

INTEGER RUNNUM,RT,CL,CS S4000430 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS ,NBK,QC,QT,HEAT, ZM,H, S4000440 

. DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S4000450 

. SIGZ, ISNDFO, CRT, LAYTOP (3) ,ITDU, KEEP S4000460 

. , MIXING, MAXDEP, LAYBOT(3) S4000470 

, ALTSV, BATCH, CL(14), CS(IO) , GASSET, lAGAIN, S4000480 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5),IFRMT(80), S4000490 
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MINUS1,MINUS9,MINS1,MINS9, S4000500 

M0DEL4 , MOD EL 5 , M0DEL6 , NNNEST , NNNTRY . LLNEST , LLMTRY . S 4 0 0 0 5 1 0 
. RT(24) .TPROPC.IDXRT S4000520 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S4000530 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S4000540 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S4000550 

CLRLNE INSLNE DELINE SA000560 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S40005/0 

INVNDR(2) ,ULINE(2) , S4000580 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP . S4000590 
! CLRLNE, INSLNE, DELINE, S4000600 

IESCAJ(3) ,NULL,IBLNK, S4000610 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S4000620 

C VEHICLE PARAMETERS S4000630 

COMMON /VCLPR/ VPAR(17) S4000640 

C TIME PARAMETERS S4000650 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S4000660 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S4000670 

C SOUNDING /FORC AST METEOROLOGICAL DATA (INITIAL LEVELS) S4000680 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S4000690 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S4000700 

Q LAYER PARAMETERS S4000710 

COMMON /LAYER/ DXX,DYY ,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S4000720 

. SIGYO(29) S4000730 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S4000740 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S4000750 

C CALCULATED NEW LAYER PARAMETERS S4000760 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,34000770 
SPEEDN(32) S4000780 

C CONVERSION FACTORS S4000790 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S4000800 

^ S4000810 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S4000820 
COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S4000830 

C-^ READ/WRITE BUFFER S4000840 

Q ^ R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S4000850 

(>*********************************************************************** 5^000860 

^ S4000870 

C EQUIVALENCE STATEMENTS S4000880 

EQUIVALENCE (IIU, IPAR( 1) ) , (lOU, IPAR(2) ) , (IPUl ,IPAR(3) ) S4000890 

,(IPU2,IPAR(4)),(IPU3,IPAR(5)) S4000900 

EQUIVALENCE (MAXDEP,GRVSET) , (IFRMT(l) ,IFRMT1) S4000910 

S4000920 

C**** END OF COMMON AREA ****S4000930 

S4000940 

^ S4000950 

DIMENSION IPL(12) S4000960 

DIMENSION WTMOL(3) ,CDHOLD(8,3) ,IER(2) S4000970 

DIMENSION RANGE(30, 1) ,BEARNG(30, 1) ,CDAMXS(1) , S4000980 

I VALUES(30,1) ,PEAKS(2,1),CLDTIM(2,2,30),CLDDTM(2,3,60) S4000990 

DIMENSION PHIS(50),UBARNK(50),SIGAPK(50),SIGEPK(50) S4001000 

S4001010 
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c 

c- 

c 


EQUIVALENCE (PLUS, RANGE) , (PLUS (181 ) .BEARNG) , 

1 (PLUS (541) .CDAllXS), (PLUS (547) .VALUES) , 

2 (PLUS(727) .PEAKS) , (ERR.IER), (CLDTIM.CLDDTM) 


-DATA STATEMENTS. 


H.2HCL.2H ,2H C.2H02.2H ,2H C.2HO ,2H ,2HAL,2H20, 

c HCL C02 CO 

DATA WTMOL/36.46,44.01,28.01/ 

DATA ISXS.NXS.INCXS / 2, 30,1/ 

DATA RAD/. 01745329/ 

DATA JVERSN/8213/ 

C 

CF FORM.AT STATEMENTS 

9001 FORMAT (2A2.38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2.6H REC. 
*,I2, IH. ,11/) 

9002 F0RMAT(1H1,38(2H**)/1X,8(2H**) ,44X,8(2H**) / 

1 1X,8(2H**) ,3X, 13HREEDM UPDATE, 15 , 1 IH LOCATION ,2A2,8X,8(2H**)/ 

2 IX, 8(2H**) ,5X,12A2,6H MODEL, 9X,8(2H**)/ 

3 1X,8(2H**) ,44X,8(2H**)/1X,38(2H**)/) 

9003 F0R1’IAT(1X,8(2H**) ,7X,31HMAXIMUM CENTERLINE CALCULATIONS 6X 

. 8(2H**)//20X,5H FOR ,3A2,I6H AT A HEIGHT OF ,F8.2,7H METERS/ 
.15X.17H DOWNWIND FROM A ,14A2,7H LAUNCH/, 4X, 

.41H CALCULATIONS APPLY TO THE LAYER BETWEEN ,F7.2,5H AND 
•F7.2,7H METERS//9X,33H THE METEOROLOGICAL DATA IS FROM ,I5,2A2 14 
. ,1X,2A2,I4/20X,16H LAUNCH TIME IS, II 1 , 2A2 , 14 , 1X,2A2 , 14/ 

. 16X,20HTIME OF EXECUTION IS . II 1 ,2A2 , 14, 1X,2A2, 14) 

9004 FORMAT(/ /35X,2(7X,5HCLOUD)/5X,5HRANGE,7X,7HBEARING,6X,5HTOTAL 6X 
120HARRIVAL DEPARTURE/4X,2(8HFROM PAD,5X) ,6HDOSAGE,7X 

2 2(4HTIME,8X)) 

9005 FORMAT (5 FI 2. 3) 

9006 FORMAT(/ /60X,5HRANGE,5X,7HBEARING/59X,9(2H — ) /F11.3 
128H IS THE MAXIMUM TOTAL DOSAGE, 17X,2F10. 1) 

9007 FORMAT (28X,8H(MILLI G/4X,33H (METERS) (DEGREES) SEC/M**3) 

1 5X,2(5H(MIN),7X)/3X,29(2H— )) 

9008 FORMAT(4X,33H(METERS) (DEGREES) (PPM SEC) ,5X,2(5H(MIN) 7X) / 

1 3X,29(2H~)) ^ 

9009 FORMAT(//30X,5HPEAK ,2(7X,5HCLOUD)/5X,5HRANGE,7X,7HBEARING 5X 

132HCONCEN- ARRIVAL DEPARTURE/ ’ ’ 

2 4X,32HFROM PAD FROM PAD TRATION,7X,2(4HTIME,8X)) 

9010 F0RMAT(4X, 3 IH (METERS) (DEGREES) (PPM) ,2(7X.5H(MIN))/ 

1 3X,29(2H— )) 

9011 FORMAT (28X,9H(MILLI G//4X,31H(METERS) (DEGREES) M**3) 

1 2(7X,5H(MIN))/3X,29(2H— )) 

90 1 2 FORMAT (/ / 60X , 5HRANGE , 5X , 7HBEARING/59X , 9 (2H— ) /FI 1 . 3 , 

134H IS THE MAXIMUM PEAK CONCENTRATION, 1 IX, 2F10. 1) 

9013 F0RMAT(43H1DIAGN0STICS FOR DOSAGE/CONCENTRATION MODEL/) - 

9014 FORMAT (2A2,A1) 

9015 FORMAT(//28X,F4.1,5H MIN. /30X,5HMEAN , 2 (7X, 5HCL0UD) /5X, 

1 5HRANGE, 7X, 7HBEARING, 5X, 32HCONCEN- ARRIVAL DEPARTURE/ 

2 4X,32HFROM PAD FROM PAD TRATION,7X,2(4HTIME,8X)) 


S4001020 
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S4 00 1-5 00 

S4001510 
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9016 FORMAT (//60X.1 7 HRANGE BEARING/59X, 9(2H— ) /FI 1 . 3 , 

116H IS THE MAXIMUM ,F4.1,25H MIN. MEAN CONCENTRATION ,2F10.1) 

9017 FORMAT ( A2 , IX, 12 A2 , 30H MODEL IS PROCESSING RANGE AT , 2A2 ,F7 . 1 , 2A2 , 
17H METERS) 

9018 FORMAT (2A2 , lOX , 2A2 , 8HPRINTING , 2A2) 

9019 FORMAT OA2) 

C 

C! ! ! ! H.E.C COPY ONLY. 

9020 FORMAT (56HD0 YOU WISH MAXIMUM CENTERLINE DOSAGE & CONCENTRATION. 

. * , 2A2 , IHY , 2A2 , 2HES , 2A2 , IH , , 2A2 , IHN , 2A2 , 4HO) :_) 

9021 FORMAT (A2) 

C! ! ! ! 

C 

9022 FORMAT(40H DIAGNOSTIC RUN. ENTER ISXS,NXS,INCXS:_) 

9023 FORMAT (73H *** REEDM WARNING 019, -1 NOT APPLICABLE, 

* IF -1 TYPED AGAIN/) 

C 
C 

IF (IVERSN .NE. JVERSN) CALL L0ADS(-1 ,0,0, 0,0, BATCH) 

C INITIALIZE. 

TIMIN = TIMAV*0. 016666667 


C 

C! ! ! 


H.E.C COPY ONLY. 

IF (BATCH) GO TO 30 

10 WRITE (ICU,9020> INVNDR,INV,OFF,ULINE,OFF 
READ (IIU,9021) IFRMTl 

IF (IFRMTl. EQ.INJ. OR. IFRMTl. EQ.INOJ) GO TO 310 

IF (IFRMTl. EQ.IBLNK. OR. IFRMTl. EQ.IYSJ.OR.IFRMTl.EQ.IYESJ) GO TO 

WRITE (ICU,9001) INV,OFF,0,0 


GO TO 10 

20 WRITE (ICU,9019) 
30 CONTINUE 


CURSUP , CLRLNE 


C! ! ! ! 

C 

JER =0 

C CLEAR WORK SPACE. 

DO 40 I = 1,900 
40 PLUS(I) = 0.0 

C COMPUTE CONVERSION FACTORS FOR ALL POLLUTANTS 

C SEE VPARS ARRAY IN PROGRAM REEDM FOR SPECIES %. 

XXX=1000. 0*22. 4*1013. 2*TEMP(1) / (273. 16*PRESS(1)) 

DO 50 1=1,3 

50 QCONV(I)=(XXX/WTMOL(I))*VPAR(I+12) 
QCONV(4)=1000.0*VPAR(16) 

IFdRUN .EQ. 4) WRITE(I0U,9013) 

C INITIALIZE PARAMETERS FOR BOUNDARY LAYERS. 

ILK=1 

IF(CALHT.GT.ALT(LAYT0P(1)+1)) ILK=2 

JF=NLAYS+ILK 

IBOT=LAYBOT(ILK) 

ITOP=LAYTOP(ILK) 

YT = DIRN(JF)+180.0 
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IF(YT .GT. 360.0) YT = YT - 360.0 
ZBSL=0.0 

IF(IBOT.GT.l) ZBSL = ALT(IBOT) 

ZTPL = ALT(ITOP+l) 

ZTPAL = ZTPL 

IF(LAYTOP(ILK+l) .GT. 0) ZTPAL = ALT(LAYTOP(ILK+l)+l) 
IF(GRVSET) CALL SHEAR(UBARNK, PHIS, SIGAPK, SIGEPK, 1) 

C 

C CHECK SEGMENT ENTRY POINT. 

C 

C 

c 

IFdRUN .NE. 4) GOTO 110 
60 TOITE(ICU,9022) 

CALL IFNBR(IFRMT,20,IER,IIU) 

IF (lER .EQ. 0) GO TO 80 
70 WRITE (ICU,9001) INV.OFF.O.O- 
IF (BATCH) GO TO 320 
GO TO 60 
80 CALL CODE (80) 

READ (IFRMT,*) ISXS ,NXS , INCXS 
IF (ISXS .NE. MINSl) GO TO 90 
JER = JER+1 

IF (JER .GT. 1) GO TO 320 
WRITE (ICU,9023) 

GO TO 60 

90 IF (ISXS .EQ. MINS9) GO TO 330 

IF (ISXS .LE.NXS. AND. INCXS. LE.NXS) GO TO 100 
GO TO 70 
100 CONTINUE 

WRITE(ICU,9014) lESCAJ 
110 CONTINUE 

LOOP THROUGH EACH RANGE (I = ISXS, NXS , INCXS) 

DO 130 1= ISXS, NXS, INCXS 
XT= FLOAT (I-l) *1000.0 

IF(. NOT. BATCH) WRITE(ICU,9017) CURSUP,MDLNAM.INV,XT,OFF 
CALL BREAK ( JF , XT , YT , I , . FALSE . , CDHOLD , PHIS , UBARNK , CLDTIM( 1,1,1) 
1 SIGAPK, SIGEPK) 

DO 120 J = 1,6 

IF(CDAMXS(J) .GT. VALUES (I, J)) GOTO 120 
CDA>DCS(J) = VALUES (I, J) 

PEAKS(1,J) = RANGE(I,J) 

PEAKS(2,J) = BEARNG(I,J) 

120 CONTINUE 
130 CONTINUE 

IF(. NOT. BATCH) WRITE(ICU, 9018) CURSUP, CLRDSP,BLNKNG,OFF 

— CALCULATE THE NUMBER OF POLLUTANTS 

NP0L=0 

DO 140 1=1,4 

IF(IPLLNTd).EQ.O) GO TO 150 
140 NPOL=NPOL+l 
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150 CONTINUE 
C 

C WRITE OUT CON,DOS,AVCOM,PASSTM,AND X,Y LOCATION 

C — CDAMXS(l-6) = CONC.GAS, DOS. GAS, TIME-MEAN CONC.GAS, 

C - C0NC.AL203, D0S.AL203, TIME-MEAN CONC. AL203 

C 

IF(NPOL.EQ.O) GO TO 310 
DO 300 JJ=1,NP0L 
IP = IPLLNT(JJ) 

IDX=(JJ-1)*7 
KDX=IP*3-3 
DO 300 IS = 1,3 
C PRINT HEADING. 

WRITE ( lOU , 9 00 2 ) IVERSN , LOCATN , MDLNAM 
A1 = ZTPL 

IF(IP .EQ. 4) A1 = ZTPAL 

WRITE ( lOU , 9003 ) ( IPL (KDX+ J) , J= 1 , 3 ) , CALHT , TITLE, ZBSL , A1 , 

. ISTIME , LSDT , I SDAY , I SMON , IS YEAR , LTIME , LSDT , LDAY , LMON , LYEAR , 
. JTIME,LSDT,JDAY,JMON,JYEAR 
IF(IS-2) 160,170,180 
160 WRITE(IOU,9009) 

GOTO 190 

170 17RITE(IOU,9004) 

GOTO 190 

180 WRITE(IOU,9015) TIMIN 
190 ISS = IS 

IF(IP .NE. 4) GOTO 220 

ISS = IS + 3 

GDI = CDAMXS(ISS) 

IPASTM = 2 

IF(IS-2) 200,210,200 
200 WRITE(IOU,9011) 

GOTO 250 

210 WRITE(IOU,9007) 

GOTO 250 
220 11-2 

CDl = CDAMXS(ISS)*QCONV(IP) 

IPASTM = 1 

IF(IS-2) 230,240,230 
230 WRITE(IOU,9010) 

GOTO 250 

240 WRITE(IOU,9008) 

C BEGIN LOOP OVER RANGES. 

250 DO 260 IXS = ISXS ,NXS , INCXS 
VALUE = VALUES (IXS, ISS) 

IF (IP .NE. 4) VALUE = VALUE*QCONV(IP) 

IF (VALUE .LT. .0005) GOTO 260 

WRITE(IOU,9005) RANGE(IXS , ISS) ,BEARNG(IXS , ISS) .VALUE, , 

1 CLDTIM( 1, IPASTM, IXS) ,CLDTIM(2, IPASTM, IXS) 

260 CONTINUE 

C PRINT MAXIMUM VALUE. 

IF(IS-2) 270,280,290 
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270 WRITE(IOU,9012) GDI , PEAKS ( 1 , ISS) ,PEAKS(2 , ISS) 

GOTO 300 

280 WRITE(IOU, 9006) GDI .PEAKS (1 , ISS) .PEAKS (2, ISS) 

GOTO 300 

290 WRITE(IOU,9016) GDI .TIMIN. PEAKS (1 .ISS) .PEAKS (2. ISS) 
300 GONTINUE 

IF(.NOT.BATGH) WRITE(IGU,9019) GURSUP.GURLFT.GLRDSP 
310 CONTINUE 

QG0NV(4) =1.0 

NNNEST = 3 
NNNTRY = 4 
GO TO 350 


320 lERROR(l) = MINSl 
GO TO 340 
330 lERROR(l) - 1 
340 NNNEST = 1 
NNNTRY = 3 
350 CONTINUE 
CALL REEDM 
END 
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REEDM SOURCE MODULE &RCNOM 


FTN4 S4 100000 

PROGRAM RCNOM(5) S4 1000 10 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S4100020 

C: : : :S4100030 
C: : S4100040 
C::: :::S410C050 

C;:: :::S4100060 

C::: ORGANIZATION: H. E. CRAZIER CO. , INC. :::S4100070 

C::: :::S410C080 

C:;: WORK FOR: DR. J. B. STEPHENS (ES84) :::S4100090 

C::: :::S4100100 

C::: PROGRAM CODE: RCNOM :::S4100110 

C::: :::S4100120 

C::: PROGRAM DESCRIPTION: :::S4100130 

C::: THIS PROGRAM CALCULATES THE DOSAGE, CONCENTRATION, TIME MEAN :::S4100140 

C::: CONCENTRATION, AND MAXIMUM CENTERLINE CONCENTRATION FOR THE ;::S4100150 

C::: MEAN WIND DIRECTION RADIAL AT EVERY 1000 METERS DOWNWIND FROM :::S4 100160 

C::: THE LAUNCH SITE. :::S4100170 

C;:: :;:S4100180 

C: :S4100190 
C; ; : : S4 100200 
C S4100210 

C S4100220 

Cc S4100230 

C**** BEGIN COMMON AREA ****84100240 

04/02/82 S4100250 

— MATH PARAMETERS AND CONSTANTS S4 100260 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S4100270 

C INPUT OPTIONS S4 100280 

REAL LAMBDA S4 100290 

INTEGER FILE, GOOD, TITLE S4 100 300 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S4 1003 10 

ISHAPE,GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S4100320 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S4 100330 

IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,BOTLAY, S4 100340 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) S4100350 

,RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S4100360 

,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DIS0(10) , S4100370 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , S4100380 

FS(20) ,MDLNAM(12) ,DBAR(20) S4100390 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S4 100400 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S4 100410 

. MODEL4, MODELS, MODEL6 S4100420 

INTEGER RUNNUM,RT,CL,CS S4 100430 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S4100440 

DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S4100450 

SIGZ, ISNDFO, CRT, LAYTOP (3) ,ITDU, KEEP S4100460 

. , MIXING, MAXDEP,LAYBOT (3) S4 100470 

. , ALTSV, BATCH, CL(14) ,CS(10) , GASSET, lAGAIN, S4100480 

ICHAR(12),IDXCL,IDXCS,IERROR(5),IFRMT(80), S4 100490 
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SA 100500 
SA100510 
S4100520 
S4100530 
S4100540 
S4100550 
S4100560 
S4100570 
S4100580 

TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT ,CLRDSP,S4100590 
CLRLNE.INSLNE, DELINE, S4 100600 
IESCAJ(3),NULL,IBLNK, S4100610 
IPAR(5),ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S4100620 


C VEHICLE PARAMETERS S4 100630 

COMMON /VCLPR/ VPAR(17) S4100640 

C time parameters S4 100650 

COMMON /TIME/ JTIME, JDAY, JYEAR.ISTIME,ISDAY,ISYEAR,LTIME, S4100660 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S4100670 

C SOUND ING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S4 100680 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S4100690 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S4100700 

C LAYER PARAMETERS S4100710 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGX0(29) , S4100720 

SIGYO(29) S4100730 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S4 100740 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S4100750 

C CALCULATED NEW LAYER PARAMETERS S4100760 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) , SIGAPN(32) , SIGEPN(32) , S4100770 
. SPEEDN(32) S4100780 

C CONVERSION FACTORS S4100790 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S4100800 

r S4100810 


C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S4100820 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S41C0830 

C READ/I7RITE BUFFER S4 100840 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S4100850 

C***********************************************************************S4 100860 

S4100870 
S4100880 
S4100890 
S4100900 
S4100910 
S4100920 
****S4100930 
S4100940 
S4100950 
S4100960 
S4100970 
S4100980 
S4100990 
S4101000 
S4101010 


C 

C EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(1)) , (IOU,IPAR(2)) , (IPUl ,IPAR(3)) 
,(IPU2,IPAR(4)),(IPU3,IPAR(5)) 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) 

C 

c**** END OF COMMON AREA 

CC 

LOGICAL IBATCH 
C 

DIMENSION IPL(12) 

DIMENSION WTMOL ( 3 ) , D I S BUF ( 1 5 , 1 ) , CDHOLD ( 8 , 3 ) , CDOUT ( 9 ) , 
1 KKMAX(3),YYMAX(3),IER(2) 

DIMENSION CDAMXS(3), 

1 CLDDTM(2,3,60) 


MINUS 1 ,MINUS9 , MINS 1 .MINS9 , 

MODEL4 , MODEL5 , MODEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24) ,TPROPC,IDXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE.INVNDR. 

. TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

CLRLNE , IN SLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2) , 
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DIMENSION PHIS (50) ,UBARNK(50) , SIGAPK(50) ,SIGEPK(50) , IDDISR( 10 , 60) S4 10 1020 



S4101030 

EQUIVALENCE (PLUS .DISBUF) , 

S4101040 

(ERR,IER) 

S4101050 


S4101060 

DATA STATEMENTS. 

S4101070 


S4101080 

DATA IPL/2H H,2HCL,2H ,2H C,2H02,2H 

,2H C,2HO ,2H ,2HAL,2H20, S4101090 

2H3 / 

S4101100 

HCL C02 CO 

S4101110 

DATA WTMOL/36.46,44.01,28.01/ 

S4101120 

DATA IBATCH /.FALSE./ 

S4101130 

DATA RAD/. 01745329/ 

S4101140 

DATA JVERSN/8213/ 

S4101150 


S4101160 

FORMAT STATEMENTS 

S4101170 


9001 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2.6H REG. S4101180 


*,I2,1H. ,11/) 

9002 FORMAT(A2) 

9003 F0RMAT(1H1,38(2H**)/1X,8(2H**) ,44X,8(2H**)/ 


S4101190 

S4101200 

S4101210 


1 1X,8(2H**) ,3X, 13HREEDM UPDATE, 15 , 1 IH LOCATION ,2A2,8X,8(2H**) / S4101220 


2 1X,8(2H**) ,5X, 12A2,6H MODEL, 9X,8(2H**)/ 

3 1X,8(2H**) ,44X,8(2H**)/1X,38(2H**)/) 
9004 FORMAT ( 


S4101230 

S4101240 

S4101250 

S4101260 

S4101270 

S4101280 

S4101290 

S4101300 

S4101310 

CS4101320 


1 1X,8(2H**) ,7X,30HDISCRETE RECEPTOR CALCULATIONS, 7X, 8 (2H**)// 

2 35X,4HFOR ,3A2/15X,17H DOWNWIND FROM A ,14A2,7H LAUNCH/4X, 

3 40HCALCULATIONS APPLY TO THE LAYER BETWEEN ,F7.2,5H AND , 

3 F7.2,7H METERS//5X,32HTHE METEOROLOGICAL DATA IS FROM ,I5,2A2, 

4 I4,1X,2A2,I4/15X,16H LAUNCH TIME IS , II 1 , 2A2 , 14, IX, 2A2 , 14/ 

5 11X,20HTIME OF EXECUTION IS , II 1 , 2A2 , 14 , IX, 2A2 , 14) 

9005 FORMAT(/49X,F5.2,5H MIN./21X,15HCALCU- PEAK,14X,25H MEAN 

ILOUD CLOUD/3X.74HRANGE BEARING LATION CONCEN- TOTAL S4 101 330 
2 CONCEN- ARRIVAL DEPARTURE/IX, 2 (8HFROM PAD,2X) ,44HHEIGHT TRATS4101340 
3ION DOSAGE TRATION TIME,6X,4HTIME) S4101350 

9006 FORMAT(75H (METERS) (DEGREES) (METERS) (PPM) (PPM/SEC) (PPM) S4 101360 

1 (MIN) (MIN),6X,10HIDENTIFIER/1X,49(2H— )) S4101370 

9007 F0RMAT(29X,3(10H(MILLI G/ )/75H (METERS) (DEGREES) (METERS) METER*S4101380 

1*3) M**3/SEC) METER**3) (MIN) (MIN) , 6X, lOHIDENTIFIER/ S4101390 

2 1X,49(2H— )) S4101400 

9008 FORMAT(F8. 1,F9. 1,F10. 1,F9.2,F10.2,F10.3,F9. 1,F10.1,2X,10A2) S4 101410 

9009 FORMAT ( IX, 37 (2H**) /IX, 52H* PEAK CONCENTRATION * TOTAL DOS4101420 

*SAGE * ,F3.0, 19HMIN. AVERAGE CONC.*/2H *,3(25H-10 DEG. POINT S4101430 

*+10 DEG.* )/lX,37(2H**)) S4101440 

9010 F0RMAT(//60X,16HRANGE BEARING/58X,9(2H— ) / S4101450 

1 F10.2.34H IS THE MAXIMUM PEAK CONCENTRATION, 1 IX, 2F10. 1/ S4101460 

1 F10.2.28H IS THE MAXIMUM TOTAL DOSAGE, 17X,2F10. 1/ S4101470 

1 F10.2,15H IS THE MAXIMUM, F6 . 2 , 24H MIN. MEAN CONCENTRATION, 2F1 0. 1)S4 10 1480 

9011 FORMAT (43H1DIAGNOSTICS FOR DOSAGE/CONCENTRATION MODEL/) S4101490 

9012 FORMAT (2A2,A1) S4101500 

9013 FORMAT(3A2) S4101510 

9014 F0RMAT(46H DO YOU WISH DISCRETE RECEPTOR CALCULATIONS? (,2A2,1HY, S4101520 
1 2A2,2HES,2A2,lH,,2A2,lHN,2A2,2HO,,2A2,3HLU//,2A2,16H OF DATA FILE) S4101530 
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2:_) S4101540 

9015 FORMAT (2A2, 6 8H ENTER DISCRETE RECEPTOR LOCATION RELATIVE TO LAUNCHS4101550 

1 PAD. A 20 CHAR./52H COMMENT MAY BE ENTERED STARTING UNDER THE ASTS4101560 
2ERISK. ,11X,1H*/34H RANGE(M) , BEARING (DEG) .HEIGHT (M) :_) S4101570 

9016 FORMATC22H CALCULATION HEIGHT 0F,F8.2,20H METERS IS TOO HIGH., S4101580 

119H PLEASE RE-ENTER:_) S4101590 

9017 F0RMAT(22H CALCULATION HEIGHT OF,F8.2,42H METERS IS GREATER THAN 5S4101600 

1 METERS (MAXIMUM) /39H AND WILL CAUSE ERRONEOUS A1203 RESULTS/ S4I01610 

2 11X,26HD0 YOU WISH TO CONTINUE? ( ,2A2 , IHY, 2A2 ,2HES, 2A2 , S4101620 

3 1HN,2A2,1H0,2A2,3H):_) S4101630 

9018 FORMAT (/26H DISCRETE RECEPTOR RANGE =,F8.1,11H, BEARING =,F6.1, S4101640 

*13H, CALC. HT. =,F7.2/21H CLOUD ARRIVAL TIME =,F5.1,29H MIN., CL0US4101650 
*D DEPARTURE TIME =,F5.1,5H MIN./2H *,4X, 13HC0NCENTRATI0N.6X, IH*, S4101660 
*9X,6HD0SAGE,9X,1H*,1X,21HTIME-AV CONCENTRATION) S4101670 

9019 FORMAT (32X.3H** ,4A2 , A1 , 2A2 , 3H **/2H * , 2 (F6. 2, 2X) ,F6. 2, 2H *, 3 (F7 . S4 101680 

*2,1X),1H*,3(F7.3,1X)) S4101690 

9020 F0RMAT(63H A MAXIMUM OF 60 DISCRETE RECEPTOR LOCATIONS HAVE BEEN ES4101700 

1NTERED./29H THIS SECTION IS TERMINATED._) S4101710 

9021 FORMAT (59H DO YOU WISH TO ENTER ANOTHER DISCRETE RECEPTOR LOCATIONS4101720 

1? (,2A2,1HY,2A2,2HES,2A2,1H, ,2A2,1HN,2A2,4H0):_) S4101730 

9022 FORMAT (73H *** REEDM WARNING 019, -1 NOT APPLICABLE, PROG. ABORTSS4101740 

* IF -1 TYPED AGAIN/) S4101750 

S4101760 


IF (IVERSN .NE. JVERSN) CALL LOADS(-l ,0,0, 0,0, BATCH) 

C INITIALIZE. 

TIMIN = TIMAV*0. 016666667 
JER = 0 


S4101770 

S4101780 

S4101790 

S4101800 

S4101810 


C CLEAR WORK SPACE. 

DO 10 I = 1,900 
10 PLUS(I) = 0.0 

C COMPUTE CONVERSION FACTORS FOR ALL POLLUTANTS 

C SEE VPARS ARRAY IN PROGRAM REEDM FOR SPECIES %. 


XXX=1000. 0*22. 4*1013. 2*TEMP(1)/ (273. 16*PRESS(1)) 

DO 20 1=1,3 

20 QCONV(I)=(XXX/WTMOL(I))*VPAR(I+12) 

QCONV (4 ) =1000. 0* VPAR (16) 

IF(IRUN .EQ. 4) WRITE(IOU,9011) 

C INITIALIZE PARAMETERS FOR BOUNDARY LAYERS. 

ILK=1 

IF (CALHT . GT . ALT (LAYTOP ( 1 ) + 1 ) ) ILK=2 

JF=NLAYS+ILK 

IBOT=LAYBOT(ILK) 

ITOP=LAYTOP(ILK) 

YT = DIRN(JF)+180.0 

IF(YT .GT. 360.0) YT = YT - 360.0 

ZBSL=0.0 

IFdBOT.GT. 1) ZBSL = ALT(IBOT) 

ZTPL = ALT(ITOP+l) 

ZTPAL = ZTPL 

IF (LAYTOP (ILK+1) .GT. 0) ZTPAL = ALT(LAYTOP(ILK+l)+l) 
IF(GRVSET) CALL SHEAR(UBARNK,PHIS,SIGAPK,SIGEPK, 1) 
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c 

C CHECK SEGMENT ENTRY POINT. 

C 

30 lER = 0 
JER = 0 

IE (.NOT. BATCH) GOTO AO 
IDOT = IBLNK 
READ(IIU,9002) IDMY 
GOTO 50 

AO WRITE(ICU,901A) INVNDR, INV,OFF, (ULINE.OEF, 1=1 , 2) 

CALL IFNBR(IFRMT,12,IER,IIU) 

IDMY = IFRMT(l) 

IF(ID>rY.EQ.MINUS9) GOTO 520 
IF (IDMY .NE. MINUS 1) GO TO 50 
JER = JER+1 

IF (JER .GT. 1) GO TO 510 
VJRITE (ICU,9022) 

GO TO 40 

50 IF(IDlfY.EQ.INJ.OR.IDMY.EQ.INOJ) GOTO 500 

IFdDMY.EQ. IBLNK. OR. IDMY. EQ.IYSJ. OR. IDMY. EQ.IYESJ) GOTO 70 
IF(IER .EQ. 0) GO TO 60 
WRITE (ICU,9001) INV, OFF, 23,0 
IF (BATCH) GO TO 510 
GO TO 40 
60 CONTINUE 

C READ FROM LU IDMY 

IBATCH = .TRUE. 

IIUTMP = IIU 
CALL CODE (2) 

READ (IDMY,*) IIU 
WRITE(ICU,9012) lESCAJ 

C 

c BEGIN DISCRETE RECEPTOR CALCULATIONS. 

C 

70 QC0NV(4) = 1000.0*VPAR(16) 

JER = 0 

CLCHTS = CALHT 
CALHT = 0.0 
NXS = 0 
LINEP =100 
LINED = 100 
DO 80 I = 1,3 
CDAMXS(I) =0.0 
YYMAX(I) = 0.0 
80 KKMAXd) = 1 
90 CONTINUE 

DO 100 I = 1,10 
100 IFRMT(15+I) = IBLNK 

IF (.NOT. BATCH .AND. .NOT. IBATCH) GOTO 120 
IF(NXS .GT. 59) GOTO 400 
ERR = EXEC(l,IIU,IFRMT,-80) 

IF(IER(2) .LE. 0) GOTO AOO 
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CALL IFNBR(IFRLIT,-26,IER,IIU) 

IF (lER .EQ. 0) GO TO 110 
WRITE (ICU,9001) INV, OFF, 23,1 
GO TO 90 

110 CALL CODE (30) 

READ ( I FRiMT , * ) XT , YT , C ALHT 
IF(XT .LT. 0.0) GOTO 400 
GOTO 240 

120 WRITE(ICU,9015) CURSUP, CLPJ)SP 

130 CALL IFNRR(IFRMT,26,IER,IIU) 

IF (lER .EQ. 0) GO TO 140 
WRITE (ICU.9001) INV, OFF, 23,1 
WRITE (ICU,9015) IBLNK,IBLNK 
GO TO 130 

140 CALL CODE (80) 

READ (IFRMT,*) XT,YT,CALHT 
IF (XT .EQ. MINSl) GO TO 150 
IF (XT .EQ. MINS9) GO TO 520 
GO TO 160 

150 raiTE(ICU,9012) lESCAJ, lESCAJ 
GOTO 30 

C CHECK FOR VALID CALCULATION HEIGHT. 

160 IF(ALT(LAYTOP(2)).GT.O.O .AND. CALHT.GT. ALT(LAYT0P(2))) GOTO 170 
IF(ALT(LAYT0P(2)).EQ.0.0 .AND. CALHT.GT. ALT (LAYTOP(l))) GOTO 170 
IF(GRVSET .AND. (CALHT .GT. 5.0)) GOTO 220 
GOTO 230 

170 WRITE(ICU,9016) CALHT 

CALL IFNBR(IFRMT,14,TER,IIU) 

IF (lER .EQ. 0) GO TO 190 

180 WRITE (ICU,9001) INV, OFF, 0,0 
GO TO 170 

190 CALL CODE (80) 

READ (IFRMT,*) CALHT 
IF (CALHT .EQ. MINSl) GO TO 210 
IF (CALHT .EQ. MINS9) GO TO 520 
IF (CALHT .GE. 0.0) GO TO 200 
GO TO 180 

200 WRITE(ICU,9013) CURSUP, CURLFT,CLRDSP 
GO TO 160 

210 WRITE (ICU, 90 12) lESCAJ 
GOTO 90 

220 WRITE(ICU,9017) CALHT, INV,OFF,INVNDR, INV, OFF 
IDMY = IBLNK 
READ (I lU, 900 2) IDMY 

WRITE ( ICU , 9 0 1 3 ) ( CURSUP , CURLFT , CLRDSP ,1=1,4) 

C WRITE BLANK LINE. 

WRITE(ICU,9002) IBLNK 
IF (IDMY .EQ. MINUS9) GOTO 520 
IF(IDMY.EQ.IYSJ.OR.IDMY.EQ.IYESJ) GO TO 230 
IFdDMY.EQ. IBLNK. OR. IDMY. EQ.INJ. OR. IDMY. EQ.INOJ) GO TO 90 
WRITE (ICU, 9001) INV, OFF, 0,0 
CO TO 220 
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S4 103000 

S4103010 

S4103020 

S4103030 

S4103040 

S4103050 

S4103060 

S4103070 

S4 103080 

S4103090 
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c 


230 WRITE(ICU,9013) (CURSUP .CURLFT ,CLRDSP, 1=1 .2) 
GET MAJOR BOUNDARY LAYER. 

2A0 JF = NLAYS + 1 

IF(CALHT .GE. ALT(LAYTOPd))) JF = JF + 1 
MAKE 3 CALCULATIONS PER DISCRETE RECEPTOR. 


250 


YTl = YTl + 360.0 


XT 


1 


YTl = YT - 10.0 
IF(YT1 .LE. 0.0) 

NXS = NXS + 1 
DISBUF(l.NXS) = 

DISBUF(2,NXS) = YTl 
DISBUF(3,NXS) = CALHT 
DO 250 J = 1,10 
IDDISR(J.NXS) = IFRMTC15+J) 

CALL^BREAK(JF,XT,YT1 , NXS, .TRUE. ,CDH0LD(1 , J) ,PHIS,UBARNK, 
CLDDTM(1,J,NXS) ,SIGAPK,SIGEPK) 


YTl = YTl + 10.0 

IF(YT1 .GT. 360.0) YTl = YTl - 360.0 


260 CONTINUE 

SAVE RESULTS IN BUFFER. 

L = 3 

DO 280 J = 1,3 
DO 270 K = 1,4 

270 DISBUF(L+K,NXS) = CDH0LD(K,J) 

280 L = L + 4 

IF (BATCH) GOTO 320 
DISPLAY DISCRETE RECEPTOR RESULTS. 
IF (LINED .LT. 22) GOTO 290 
LINED = 5 

WRITE(IC0,9009) TIMIN 


290 CONTINUE 

WRITE(ICu!9018) XT,YT, CALHT , CDHOLD ( 4 , 2 ) , CLDDTM ( 1 , 2 , NXS ) 
DO 310 JJ = 1,4 
IP = IPLLNT(JJ) 

IF(IP .EQ. 0) GOTO 310 
L = 0 

IF(IP .EQ. 4) L = 4 
KDX = IP*3 - 3 
K = 0 

DO 300 I = 1,3 
DO 300 J = 1,3 


K = K + 1 ^ ^ 

300 CDOUT(K) = CDHOLD(I+L, J)*QCONV(IP) 

LINED = LINED + 2 

WRITE ( ICU , 90 1 9 ) INV , ( IPL (KDX+ J) , J= 1 , 3) , OFF , CDOUT 
310 CONTINUE 

C PRINT DISCRETE RECEPTOR RESULTS FOR AL203. 


320 CONTINUE 

DO 360 JJ = 1,4 

IF(IPLLNT(JJ) .NE. 4) GOTO 360 
IF(LINEP .LT. 53) GOTO 330 


S4103100 
S4103110 
S4103120 
S4103130 
S4103140 
S4103150 
S4103160 
S4103170 
S4103180 
S4103190 
S4103200 
S4103210 
S4103220 
S4103230 
S4103240 
S4103250 
S4103260 
S4103270 
S4103280 
S4103290 
S4103300 
S4103310 
S4103320 
S4103330 
S4103340 
S4103350 
S4103360 
S4103370 
S4103380 
S4103390 
S4103400 
S4103410 
S4103420 
S4103430 
S4103440 
S4103450 
S4103460 
S4103470 
S4103480 
S4103490 
S4 103500 
S4103510 
S4103520 
S4103530 
S4103540 
S4103550 
S4103560 
S4103570 
S4103580 
■ S4103590 
S4103600 
S4103610 
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c 


LINEP = 27 


WRITE ( lOU , 9003 ) IVERSN , LOCATM, MDLNAM 
WRITE(IOU,9004) (IPL(9+J) , J=1 ,3) TITLE ZBSI 7TPAT 

TOITE(IOU,9005) TIMIN 
WRITE(IOU,9007) 

330 CONTINUE 

YTl = DISBUF(2,NXS) 

DO 360 J = 1,3 
DO 340 I = 1,3 

CDOUT(I) = CDHOLD(I+4,J)*QCONV(4) 

IF(CDOUT(I) .LT. CDAMXS(I)) GOTO 340 
CDAMXS(I) = CDOUT(I) 

YYMAX(I) = YTl 
KKMAX(I) = NXS 
340 CONTINUE 

IF(CDOUTd) .LT. 0.0005 .AND. CDOUT(2).LT 0 005 AND 
1 CDOUT(3).LT.0.0005) GOTO 350 -AND. 

LINEP = LINEP + 1 

IF (J.NE.2) WRITE ClOU, 9008) XT,YT1 .CALHT. (CDOUT(I) , 1=1 3) 

3a0 YTI . YTl + 10. I- 

360 SSue'"^' 

IF(BATCH) GOTO 90 
IF(NXS .LT. 60) GOTO 370 
WRITE(ICU,9020) 

GOTO 400 

370 IF(IBATCH) GOTO 90 

WRITE ( ICU , 902 1 ) INVNDR , INV, OFF , ULINE , OFF 

IDMY = IBLNK 

READ(IIU,9002) IDMY 

IF(IDMY ,EQ. MINUS9) GOTO 520 

IF (IDMY .NE. MINUS 1) GOTO 380 

WRITE(ICU,9012) lESCAJ 

GOTO 30 

380 JF(IDMY.EQ. IBLNK. OR. IDMY. EQ.IYSJ. OR. IDMY. EQ.IYESJ) GO TO QO 
F (IDMY. EQ. INJ. OR. IDMY. EQ. INOJ) GO TO 390 
WRITE (ICU, 9001) INV,OFF,23,2 
GO TO 370 

390 WRITE(ICU, 9013) CURSUP,CURLFT,CLRDSP 
WRITE BLANK LINE. 

WRITE(ICU,9002) IBLNK 

400 CONTINUE 

IF(.NOT. IBATCH) GOTO 410 
IIU = IIUTMP 
WRITE(ICU,9002) IBLNK 


S4103620 
S4103630 
S4103640 
S4103650 
S4103660 
S4103670 
S4103680 
S4103690 
S4103700 
S4103710 
S4103720 
S4103730 
S4103740 
S4103750 
S4103760 
S4103770 
S4103780 
S4103790 
S4103800 
S4103810 
S4103820 
S4103830 
S4103840 
1,10)54103850 
S4103860 
S4103870 
S4103880 
S4103890 
S4103900 
S4103910 
S4103920 
S4103930 
S4103940 
S4103950 
S4103960 
S4103970 
S4103980 
S4103990 
S4104000 
S4104010 
S4104020 
S4104030 
S4 104040 
S4104050 
S4104060 
S4104070 
S4104080 
S4104090 
S4104100 
S4104110 
S4104120 
S4104130 
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410 DO 420 JJ = 1 

1 CDAMXS(3) ,TI1-IIN,DTSBUF(1 ,KKMAX(3) ) ,YYMAX(3) 

420 CONTINUE 

DO 490 JJ = 4, 1,-1 
IP = IPLLNT(JJ) 

IF(IP .EQ. 0 .OR. IP .EQ. 4) GOTO 490 
KDX = IP*3 - 3 
DO 430 J = 1,3 
KKFIAX(J) = 1 
YYMAX(J) =0.0 
430 CDAMXS(J) = 0.0 
LINEP = 100 
DO 480 KK=1,NXS 
IF(LINEP .LT. 53) GOTO 440 
LINEP = 27 

WRITE(IOU,9003) IVERSN,LOCATN,l‘n)LNAM 

MUTTFfTOU 9004) (IPL(KDX+J) ,J= 1,3) , TITLE, ZBSL,ZTPL, 

1 ISTIME , LSDT , I SDAY , ISMON , ISYEAR , LTIME , LSDT , LDAY , LMON , LYE , 

2 JTIME,LSDT,JDAY,JMON,JYEAR 
WRITE(IOU,9005) TIMIN 
WRITE(IOU,9006) 

440 CONTINUE 

XT = DISBUF(1,KK) 

YTl = DISBUF(2,KK) 

CALHT = DISBUF(3,KK) 

L = 3 

DO 470 J = 1,3 

DO 450 I = 1,3 ^ ^ 

CDOUT(I) = DISBUF(I+L,KK)*QCONV(IP) 

IF(CD0UT(I) .LT. CDAIIXS(I)) GOTO 450 
CDAMXS(I) = CDOUT(I) 

YYMAX(I) = YTl 
KKMAX(I) = KK 

C dS^T^PRINT .IF VALUES ARE LESS THAN 

mcDOUT(l).LT.0.005 .AND. CDOUT(2) .LT.0.005 .AND. 

1 CDOUT(3).LT. 0.0005) GOTO 460 

m^NE 2rmiTE(IOU,9008) XT.YTl ,CAEHT, (CDOOT(I). 1-1.3) , 

IF(J.NE.2) iisBTO(L.4.KK),c™TOa.J,KK), IBLKK.I- ,10) 

IF(J.E0.2) miTE(IOO,9008) XT.YTl .CALHT. (CDOIIT(I) .1-1 .3) , 

1 DISBUF(L+4,KK) ,CLDDTM(1,J,KK),(IDDISR(I,KK),I l.iO) 

460 YTl = YTl + 10.0 

IF(YT1 .GT. 360.0) YTl = YTl - 360.0 

470 L = L + 4 

URITEaoU,9010) (CDA11XS(I),DISBUF(1,KK^(I)),YY1I^ 

1 CDAMXS{3), TIMIN, DISBUFU,KKMAX(3)),YYMAX(3) 

490 CONTINUE 

CALHT = CLCHTS 


), 


S4104140 

S4104150 

S4104160 

S4104170 

S4104180 

S4104190 

S4104200 

S4104210 

S4104220 

S4104230 

S4104240 

S4104250 

S4104260 

S4104270 

S4104280 

S4104290 

S4104300 

S4104310 

S4104320 

S4104330 

S4104340 

S4104350 

S4104360 

S4104370 

S4104380 

S4104390 

S4104400 

S4104410 

S4104420 

S4104430 

S4104440 

S4104450 

S4104460 

S4104470 

S4104480 

S4104490 

S4104500 

S4104510 

S4104520 

S4104530 

S4104540 

S4104550 

S4104560 

S4104570 

S4104580 

S4104590 

S4104600 

S4104610 

S4104620 

S4104630 

S4104640 

S4104650 
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500 CONTINUE 


GOTO 530 

S410A660 



S4104670 


510 lERROR(l) = MINSl 

S4104680 


GOTO 530 

S4104690 


520 lERROR(l) = 1 

S4104700 

s 

530 NNNEST = 1 

S4104710 

i 

1 

NNNTRY = 3 

S4104720 


GALL REEDM 

S4104730 


END 

S4104740 

1 


S4104750 



I 


m 


i 


P 


I 


K 
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REEDM SOURCE MODULE &RCONN 


SUBROUTINE BREAK (JF , XO , YO , IXS , DISCRT , BUFDIS , PHIS ,UBARNK , CLDTIM , 
1 SIGAPK.SIGEPK) 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 


S42000C0 

S4200010 

S4200020 

S4200030 

S4200040 


THIS SUBPvOUTINE CALCULATES CONCENTRATION, DOSAGE, TIME MEAN CONCEN- 
TRATION AT MAXIMUM CENTERLINE OR DISCRETE RECEPTOR LOCATIONS. 


Cc 

C**** BEGIN COMMON AREA ****S- 

C 04/02/82 

C MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI ,G,CP,MAXLEV,GAMMAI,GAMMAC S' 

C INPUT OPTIONS 

REAL LAMBDA ^ 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP , b 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA, S 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S 

1 iplace,iprint,sigmar,sigmer,lsite,botlay, s 

i ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) S 

i ,RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S 

,IPLLNtU) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DISO(10) , S 

' TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , S 

! FS(20),MDLNAM(12),DBAR(20) S 

C COUNTERS , FLAGS , GENERAL AND INDEX VARIABLES S 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S 

MODEL4, MODELS, MODEL6 ^ 

INTEGER RUNNUM,RT,CL,CS c 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , STGYNK , £ 

SIGZ, ISNDFO, CRT, LAYTOP(3),ITDU, KEEP £ 

.MIXING, MAXDEP, LAYBOT(3) - 

, ALTSV, BATCH, CL(14), CS(IO) , GASSET, lAGAIN, £ 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , £ 

MINUS1,MINUS9,MINS1,MINS9, ' 

M0DEL4,M0DEL5,M0DEL6,NNNEST,NNNTRY,LLNEST,LLNTRY, J 

RT(24) ,TPROPC,IDXRT ‘ 

Q TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. £ 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, j 

TAB , T AB 2 , S ETT AB , CLRT AB , CURSUP , CURS DN , CURLFT , CLRDS P , > 

CLRLNE.INSLNE, DELINE , ; 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , . 

INVNDR(2) ,ULINE(2) , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , ! 
’ CLRLNE.INSLNE, DELINE, j 

IESCAJ(3) ,NULL,IBLNK, ' 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) ' 
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c VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) c/onn.in 

C time PARAMETERS S4200510 

COMMON /TIME/ JTIME, JDAY, JYEAR, ISTIME, ISDAY, ISYEAR.LTIME, S4200530 

^ • ■LDAY,LYEAR,ISM0N(2),JM0N(2),LM0N(2),LSDT(2) S4200540 

^ SOUNDING/FORCAST meteorological data (initial LEVELS) S4200550 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) .PRESSOO) , S4200560 

RH(30) ,PTEMP(30),SIGEP(30),SIGAP(30) S4200570 

c layer parameters 54^00380 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) . S4200590 

* SIGYO(29) 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) 84700610 

COMMON /BLAYR/ DIRB (6) , SPEEDB (6) ,TEMPB(6) S4700670 

^ CALCULATED NEW LAYER PARAMETERS S4''00630 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S420C640 

C CONVERSION^FACTORS^^ • S4200660 

COMMON /CNVRT/ QC0NV(4) .QPDEPH S4200670 

0 

C' * ****COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S4200680 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S4200700 

C READ/WRITE BUFFER clono'in 

^ ^ R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S4'^00720 

c 

C EQUIVALENCE STATEMENTS S4 7007 SO 

EQUIVALENCEdIU, IPAR(l) ) , (lOU, IPAR(2) ) , (IPUl , IPAR(3) ) S4200760 

,(IPU2,IPAR(4)),(IPU3,IPAR(5)) S4200770 

^ EQUIVALENCE (MAXDEP .GRVSET) . (IFRMT(l) , IFRMTl) S4200780 

r**A* T7 XT T^ Tx T, „ S4200790 

^ end of common AREA ****S4200800 

LOGICAL DISCRT S4200870 

REAL LAT S4 2 008 30 

C CD ARRAY = CONC.GAS, DOS. GAS, TIME-MEAN CONC.GAS, S4200840 

C C0NC.AL203, D0S.AL203, TIME-MEAN C0NC.AL203 S4200850 

DIMENSION CD(50,6) ,YMCDL(3) ,LMCDL(3) ,CDMAX(3) ,YPI(50,2) ,BUFDIS(1) ,S4200860 
1 SIGYI(50,2),NS0URC(2),AVGSY(2),PASTIM(2),CLDTIM(4),CDOUT(6) S4200870 

DIMENSION RANGE(30,1),BEARNG(30,1).SIGYBR(30.1), S4200880 

1 VALUES(30,1),PHIS(1),UBARNK(1),SIGAPK(1),SIGEPK(1) S4200890 

EQUIVALENCE (PLUS, RANGE) , (PLUS(181) .BEARNG) , S4200900 

1 (PLUS (36 1 ), SIGYBR) , (PLUS (54 7 ), VALUES) S4200910 

EQUIVALENCE (CDOUT(l) ,S2GS) , (CD0UT(2) , SlGS) , (CD0UT(3) , S3GS) , S4200920 

1 (CD0UT(4),S2AL),(CD0UT(5),S1AL),(CD0UT(6),S3AL) S4200930 

EQUIVALENCE (NSOURC(l) ,NS01) , (NS0URC(2) ,NS02) S4200940 

DATA NCAT /6/, RADI /57. 29578/, SQR2P /2. 5066283/, RAD/. 01745329/ S4200960 
*, TWOPI/6. 283185/ , TIMI/ . 016666667/ S4200970 

C*** INITIAI IZE S4200980 

^ iWiiiALiiCt. S4200990 

XOP = XO S4201000 

S4201010 
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IF (XOP .EQ. 0.0) XOP = 5.0 
LOOP = 0 
10 CONTINUE 

AVGSY(l) = 0.0 
AVGSY(2) =0.0 
NSGYGS = 0 
NSGYAL = 0 
TIMALG = 1.E20 
TIMALA = 1.E20 
TIMDLG =0.0 
TIMDLA =0.0 
NSOl = 0 
NSOGS = 0 
NS02 =0 
DO 30 M = 1,50 
DO 20 J = l.NCAT 
20 CD(M,J) = 0.0 
DO 30 J = 1,2 
SIGYI(M.J) = 0.0 
30 YPI(M.J) = 0.0 
C 

C*** BEGIN LOOP OVER MAJOR BOUNDARY LAYERS. 

C 

NILK = 0 

DO 330 ILK = 1,2 
IF (ILK .EQ. 1) GOTO 40 
IF(.NOT.GRVSET) GOTO 330 
IF(LAYTOP(NLK+l) .EQ. 0) GOTO 330 
IBOT = LAYTOP(NLK) +1 
ITOP = LAYT0P(NLK+1) 

JF = NLAYS + NLK + 1 ■ 

GOTO 50 
40 CONTINUE 
NLK = 1 

1F(CALHT .GT. ALT(LAYTOP(l))) NLK = 2 
JF = NLAYS + NLK 
IBOT = LAYBOT(NLK) 

ITOP = LAYTOP(NLK) 

ZBL = ALT (IBOT) 

IF(DISCRT .OR. LOOP.GT.O) GOTO 50 
YO = DIRN(JF) + 180.0 
1F(Y0 .GT. 360.0) YO = YO - 360.0 
50 CONTINUE 

NILK = NILK + 1 
SPEEDI = l./SPEEDN(JF) 

ZTLZBL = ALT(ITOP+l) - ZBL 

IF(IRUN. EQ. 4) WRITE (lOU, 9001) XO.YO , ILK, CALHT, ZBL, ZTLZBL 
9001 FORMAT(/35H DIAGNOSTICS FOR dQIJNWIND LOCATION , 2F10. 2/16 ,-3E13. 6) 
C 

C*** BEGIN LOOP OVER METEOROLOGICAL LAYERS. 

C 

DO 320 M = IBOT, ITOP 


S4201020 

S420L030 

S4201040 

S4201050 

S4201060 

S4201070 

S4201080 

S4201090 

S4201100 

S4201110 

S4201120 

S4201130 

S4201140 

S4201150 

S4201160 

S4201170 

S4201180 

S4201190 

S4201200 

S4201210 

S4201220 

S4201230 

S4201240 

S4201250 

S4201260 

S4201270 

S4201280 

S4201290 

S4201300 

S4201310 

S4201320 

S4201330 

S4201340 

S4201350 

S4201360 

S4201370 

S4201380 

S4201390 

S4201400 

S4201410 

S4201420 

S4201430 

S4201440 

S4201450 

S4201460 

S4201470 

S4201480 

S4201490 

S4201500 

S4201510 

S4201520 

S4201530 
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IFL = 1 
IFAL = 1 

IF (.NOT.GRVSET) IFAL = 0 

SIGXAL = 0.0 

SIAL = 0.0 

S2AL =0.0 

S3AL =0.0 

SIGS = 0.0 

S2GS =0.0 

S3GS = 0.0 

IF(IRUN .EO. A) WRITE(IOU,9002) M 
9002 FORMAT (19H0*** FOR MET. LAYER, 13) 
C 


c** 

C*A 

c 


COMPUTE .XBAR & YEAR OF SOURCE M WITH RESPECT 
V/IND DIRECTION (DIRN(JF)) FOR GAS. 


TO BOUNDARY LAYER 


A1 = DIRN(JF)*RAD 
CALL C00RD(A1,M,X0,Y0 ,XS,YS,X,Y) 
IF(IFLG.GE.O) GO TO 60 
IFL = 0 
60 CONTINUE 

IF (.NOT.GRVSET) GO TO 90 
C 


c** 

c** 

c** 

c 


ADJUST XBAR & YEAR DUE TO GRAVITATIONAL 
COMPUTE SIGMAS USING ADJUSTED XBAR. 
COMPUTE FRONT-END TERMS FOR AL203. 


SETTLING FOR AL203. 


IF(.NOT. (DISCRT .OR. LOOP.GT.O)) GOTO 70 
A1 = DIRN(M)*RAD+PHIS(M) 

CALL C00RD(A1,M,X0,Y0 ,XS,YS,XAL,YAL) 

IF (IFLG .GE. 0) GO TO 80 
IFAL = 0 
GO TO 80 

70 PHISM = (DIRN(M)+180.0)*RAD + PHIS(M) 

IF(PHISM .GT. nTOPI) PHISM = PHISM — TWOPI 
IF(PHISM .LE. 0.0) PHISM = PHISM + TWOPI 
THETC = DY(M)*RAD 
SR = ABS (PHISM - THETC) 

IF (SR .GT. PI) SR = TWOPI-SR 

SR = ABS(PI-SR) 

A1 = DX(M) 

SS = PI - (SR + ARSIN(A1*SIN(SR)/X0P)) 

XAL = A1*A1 + XO*XO - 2.0*A1*X0*C0S(SS) 
IF(XAL .LE. 0.0) IFAL = 0 
XAL = ABS (XAL) 

XAL = SQRT(XAL) 

SK = 1.0 

IF(ABS (PHISM - THETC) .GT. PI) SK = -1.0 

IF(PHISM .LT. THETC) SK = -1.0*SK 

YAL = THETC + SK*SS 

IF(YAL .LE. 0.0) YAL = YAL + TWOPI 

IF(YAL .GT. TITOPI) YAL = YAL - TWOPI 


S4201540 

S4201550 

S4201560 

S4201570 

S4201580 

S4201590 

S4201600 

S4201610 

S4201620 

S4201630 

S4201640 

S4201650 

S4201660 

S4201670 

S4201680 

S4201690 

S4201700 

S4201710 

S4201720 

S4201730 

S4201740 

S4201750 

S4201760 

S4201770 

S4201780 

S4201790 

S4201800 

S4201810 

S4201820 

S4201830 

S4201840 

S4201850 

S4201860 

S4201870 

S4201880 

S4201890 

S4201900 

S4201910 

S4201920 

S4201930 

S4201940 

S4201950 

S4201960 

S4201970 

S4201980 

S4201990 

S4202000 

S4202010 

S4202020 

S4202030 

S4202040 

S4202050 
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80 CONTINUE 

COMPUTE SIGMAS FOR AL203 

CALL^SIGIIA(XAl!m. ,PHIS(M)*RADI) 

SIGXAL = SIGXNK 

IF(SIGYNK .LE. 0.0) GOTO 90 

SIGYAL = SIGYNK 

IF(SIGZ .LE. 0.0) GOTO 90 

SIGZAL = SIGZ 

UBRIAL = l./UBARNK(M) 

rnMPiTTF FRONT-END TERMS FOR AL203 

* Si'aL - q(h)*UBRIAL/(2.0*SQR2P*SIGYAL*(ALT<M+1)-A1.I(M))) 

?R^DECAY GI 0 0) SIAL . S1AL»EXP(-DECAY*XAL*DBRIAL> 
"SsIG^l'.GT. 0.0) S2AL - S1AL*UBARNK(M) / (WP^SIGXAL) 
IF(DISCRT .OR. LOOP.GT.O) ALATAL = YAL/SIGYNK 

C** COMPUTE SIGMAS AND FRONT-END TERMS FOR GASES. 

90 O.AND.IFAL .EQ. 0) GO TO 280 

IF(LOOP .GT. O.OR.IFL .EQ. 0) GOTO 100 

CALL SIGMA(X,M,JF,0,SIGAPN(M) .SIGEPN(M) ,DDIR(M)) 

IF(SIGYNK .LE. 0.0) GOTO 100 

Sicf- om /fsSuF) *2 . 0*SQR2P*SIGYffi* (ALT(M.l) -ALT(«) ) ) 

GT 0 0) SIGS - S1GS*EXP(-DECAY*X/SPEEDN(JF)) 
IFCSIGXNk’.GT. 0.0) S2GS = S1GS*SPEEDN(JF) /(SQR2P*SIGXNK) 
IF(DISCRT) ALATGS = Y/ SIGYNK 
C 

100 IF(Q(M) .LE. 0.0) GOTO 260 

** begin loop over GRAVITATIONAL SETTLING CATEGORIES. 

C** CALCULATE VERTICAL TERl’I. 

C 

VSXSUI =0.0 
VERTGS =0.0 

c ABSoStION* COEFFICIENT FOR GASES IN GAMMAP(21) 

C CHE^ VERTICAL^tSm VARIABLES. SKIP GAS, AL203 OR BOTH. 

JO = 0 

rr/cTpy^TF no OR LOOP. GT. 0 . OR. IFL .EQ. 0) JO =1 

IF(.NOt!gRVSET. OR. SIGZAL. LE.O.O.OR.XAL.LE. 0.0. OR. IFAL.EQ.0)J1 

IF(J0 .GT. Jl) GOTO 260 
DO 170 J = JO.Jl 
IF(J .EQ. 0) GOTO no 
SIGZ = SIGZAL 
VSXSUI =■ VS(J)*XAL*UBRIAL 
GAltMA = GAMMAP(J) 
no CONTINUE 
120 CONTINUE 


=0 


S4202060 

S4202070 

S4202080 

S4202090 

S4202100 

S4202110 

S4202120 

S4202130 

S4202140 

S4202150 

S4202160 

S4202170 

S4202180 

S4202190 

S4202200 

S4202210 

S4202220 

S4202230 

S4202240 

S4202250 

S4202260 

S4202270 

S4202280 

S4202290 

S4202300 

S4202310 

S4202320 

S4202330 

S4202340 

S4202350 

S4202360 

S4202370 

S4202380 

S4202390 

S4202400 

S4202410 

S4202420 

S4202430 

S4202440 

S4202450 

S4202460 

S4202470 

S4202480 

S4202490 

S4202500 

S4202510 

S4202520 

S4202530 

S4202540 

S4202550 

S4202560 

S4202570 
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l./SQRT(2) = .70710678 
SIGZI = .70710678/SIGZ 

A1 /’ 


A1 
A2 
A3 
A4 
A5 
A6 
A6 

SUM = A3 + A6 


+ VSXSUI)*SIGZI 


(-ALT(M) + CALHT 

"(ALT(M+1) - CALHT - VSXSUI)*SIGZI 
ERFXS(A1,A2) 

ALT(M+1) 


(-ZBL - ZBL + 


-(ZBL + ZBL - ALT(M) - CALHT 
ERFXS(A4,A5) 

GAMMA*A6 


CALHT - VSXSUI)*SIGZI 
VSXSUI)*SIGZI 


C* 


SUML = -1.0 
GAMl = 1.0 
GAM2 = GAMMA 
GAM3 = GAM2* GAMMA 
AI = 0.0 

nn SUMMATION LOOP FOR VERTICAL TERM 

130 AI = AI + 2.0 

AH : * VSXSUI)*SIGZI 

IFCSUML .LT. 0.0) GOTO 140 - VSXSUI)»SIGZI 

140 '•“> 15° 

~ ALTCM) + CALHT + VSXSUI)*SIGZI 

- 'fSXSUI)*SIGZI 


AI 

A2 

A3 

A3 

A4 

A5 

A6 

A6 

A7 

A8 

A9 

A9 


ZBL 


ALT(M+1) 


c 
c** 
c** 


' ERFXS(A1,A2) 

^ GAM2*A3 

(AI*ZTLZBL - ZBL - ZBL + 
-(-AI*ZTLZBL 
ERFXS(A4,A5) 

GAM3*A6 

(AI*ZTLZBL + 

-(-AI*ZTLZBL - ALT(M) 
ERFXS(A7,A8) 

GAM2*A9 
A12 = ERFXS(A10,All) 

A12 = GAM1*A12 

SUM = SUM + A3 + A6 + A9 + A12 

GAMl = GAM2 

GAM2 = GAM3 

GAM3 = GAM3*GAMMA 

SUML = SUM 

GOTO 130 

150 CONTINUE 

IF(J ,GT. 0) GOTO 160 
VERTGS = SUM 
GOTO 170 

160 VERTAL = VERTAL + SUM*FS(J) 

170 CONTINUE 


ALT(M+1) + CALHT - VSXSUI)*SIGZI 
+ ZBL - ALT(M) - CALHT + VSXSUI)*SIGZI 


CALHT - VSXSUI)*SIGZI 
CALHT + VSXSUI)*SIGZI 


l“ME-MLr“Ncl ™ 


S4202580 
S4202590 
S4202600 
S4202610 
S4202620 
S4202630 
S4202640 
S4202650 
S4202660 
S4202670 
S4202680 
S4202690 
S4202700 
S4202710 
S4202720 
S4202730 
S4202740 
S4202750 
S4202760 
S4202770 
S4202780 
S4202790 
S4202800 
S4202810 
S4202820 
S4202830 
S4202840 
S4202850 
S4202860 
S4202870 
S4202880 
S4202890 
S4202900 
S4202910 
S4202920 
S4202930 
S4202940 
S4202950 
S4202960 
S4202970 
S4202980 
S4202990 
S4203000 
S4203010 
S4203020 
S4203030 
S4203040 
S4203050 
S4203060 
S4203070 
S4203080 
S4203090 
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o o 


IF (IFAL .EQ. 0) GO TO 180 
SIAL = S1AL*VERTAL 
S2AL = S2AL*VERTAL 
180 IF (IFL .EQ, 0) GO TO 190 
SIGS = S1GS*VERTGS 
S2GS = S2GS*VERTGS 
190 IF (IFAL .EQ. 0) GO TO 200 
C .35355339 = 1 . / (2*SQRT(2) ) 

A1 = UBARNK(M)*TIMAV*. 35355339/SIGXNK 
A1 = ERFXS(A1,0.0) 

S3AL = S1AL*A1/TIMAV 
200 IF (IFL .EQ. 0) GO TO 210 

Al = SPEEDN(JF)*TIMAV*.35355339/SIGXNK 
A1 = ERFXS(A1,0.0) 

S3GS = S1GS*A1/TIMAV 


C 


210 IF(.NOT. (DISCRT .OR. LOOP.GT.O)) GOTO 230 
ALATAL = -.5*ALATAL*ALATAL 
IF(ALATAL .LT. -60.0) GOTO 220 
ALATAL = EXP (ALATAL) 

SIAL = SIAL* ALATAL 
S2AL = S2AL*ALATAL 
S3AL = S3AL*ALATAL 
220 IF(LOOP .GT. 0) GOTO 230 
ALATGS = -.5*ALATGS*ALATGS 
IF(ALATGS .LT. -60.0) GOTO 230 
ALATGS = EXP (ALATGS) 


SIGS = S1GS*ALATGS 
S2GS = S2GS*ALATGS 
S3GS = S3GS*ALATGS 

230 CONTINUE ^ 

1F(SIGYAL .LE. 0.0. OR. IFAL .EQ. 0) GOTO 240 

AVGSY(2) = AVGSY(2) + SIGYAL 

240 IF(SIGYNK.LE.0.0 .OR. LOOP. GT. 0. OR. IFL .EQ. 0) GOTO 250 
AVGSY(l) = AVGSY(l) + SIGYNK 
NSGYGS = NSGYGS + 1 


SmStE^CLOUD arrival & DEPARTURE TIMES FOR THIS MET. LAYER. 
NOTE: NEGATIVE XBAR ("X") IS VALID. 

260 IF (IFL .EQ. 0. OR. ILK .GT. 1) GO TO 270 

TIMAKG = (X-2. 15*SIGXNK)*UBRIGS+RISTIM(M) 

TIMDKG = (X+2. 15*SIGXNK)*UBRIGS+RISTIM(M) 

TIMALG = AMIN KTIMALG, TIMAKG) 

TIMDLG = AMAXKTIMDLG, TIMDKG) 

.EQ. 0) GO TO 280 

(XAL-2. 15*SIGXAL)*UBRIAL+RISTIM(M) 

(XAL+2. 15*SIGXAL)*UBRIAL+RISTIM(M) 

TIllALA = AMINKTIMALA.TIMAKA) 

TIMDLA = AMAXl (TIMDLA,TIMDKA) 


270 IF (IFAL 
TIMAKA = 
TIMDKA = 


C 


S4203100 

S4203110 

S4203120 

S4203130 

S4203140 

S4203150 

S4203160 

S4203170 

S4203180 

S4203190 

S4203200 

S4203210 

S4203220 

S4203230 

S4203240 

S4203250 

S4203260 

S4203270 

S4203280 

S4203290 

S4203300 

S4203310 

S4203320 

S4203330 

S4203340 

S4203350 

S4203360 

S4203370 

S4203380 

S4203390 

S4203400 

S4203410 

S4203420 

S4203430 

S4203440 

S4203450 

S4203460 

S4203470 

S4203480 

S4203490 

S4203500 

S4203510 

S4203520 

S4203530 

S4203540 

S4203550 

S4203560 

S4203570 

S4203580 

S4203590 

S4203600 

S4203610 
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280 IFdRUN .EQ. 4) WRITE(IOU,9003) JF.LOOP.DISCRT ALTfM') ATTrM+n 

1 OfM") .SPFFDMr'Nf'i q-prrnM/ TT’\ TTT5 A -nxTTr r\ * ’ LT 1 ) 


Q(M) ,SPEEDN(M) .SPEEDN(JF) ,UBARNK(M) , 
SIGXAL , SIGXNK , SIGYAL , SIGYNK , SIGZAL , SIGZ 
VERTAL , VERTGS , ALATAL , ALATGS , 

T IMAKA .TIMDKA,TIMAKG,TIMDKG,XAL,X,YAL,Y 
CDOUT 


9003 FORMAT ( 


39H 

34H 

43H 

31H 

31H 

15H 


JF,LOOP,DISCRT,ALT(M) ,ALT(M+1) ,Q(M) =,2I5,L5, 1P3E14 5/ 
SPEEDN(M).SPEEDN(JF),UBARNK(M) =,3E14.5/ 

S I GX AL , S I GXNK , S I GYAL , S I GYNK .SIGZAL, SIGZ =,6E14.5/ 

VERTAL , VERTGS , ALATAL , ALATGS = , 4E 1 4 , 5 / 
TIMAKA.TIMDKA.TIMAKG.TIMDKG =,4E14.5/ 

XAL.X.YAL.Y =,4E14.5/ 

711H CONC.GAS=,E12.6,9H D0S.GAS=,E12.6,20H TIME-MEAN CONG GA9- 
9C . 1u03=!e 1 2°6 ) • ^ ^ 2 . 6 . 1 IH DOS . AL203= . El 2 . 6 . 2 IHTIME-MEAN ’ 

LOAD GOOD RESULTS IN ARRAYS. 

IF (ILK .GT. 1) GOTO 300 
IF(S1GS.LE.0.0 .OR. LOOP.GT.O) GOTO 300 
NSOGS = NSOGS+1 


DO 290 J = 1,3 
290 CD(NSOGS.J) = CDOUT(J) 

S IGYI (NSOGS, 1) = SIGYNK 
YPI (NSOGS, 1) = Y 
300 IF(S1AL .LE. 0.0) GOTO 320 
IF (ILK .EQ. 1) NSOl = NSOl+1 
NS02 = NS02 + 1 
DO 310 J = 4,6 
310 CD(NS02,J) = CDOUT(J) 
SIGYI(NS02,2) = SIGYAL 
YPI(NS02,2) = YAL 
320 CONTINUE 


C 


C* END MET. LAYER LOOP. 
C 


IF(ILK .GT. 1) GOTO 330 
PASTIM(l) = AMAXl (TIMALG*TIMI,0.0) 
PASTIM(2) = TIMDLG*TIMI 
330 CONTINUE 
C 

C** END OF MAJOR BOUNDARY LAYERS. 

C 


IF(NILK .NE. 1) GOTO 340 
AVGSY(2) = AVGSY(l) 
NSGYAL = NSGYGS 


C* 

C* 

C* 

C* 

C 


340 IF(.NOT.DISCRT) GOTO 390 

DISCRETE RECEPTOR. STORE RESULTS INTO BUFDIS ARRAY. 
LOCATION 1 = CONC.GAS, 2 = DOS. GAS, 3 = TIME-MEAN CONC GAS 
4 - CLOUD ARRIVAL TIME.GAS. 5 - C0K.AL203.' 6 - SoS A^2of ’ 
7 - TIME-MEAN C0NC.AL203, 8 = CLOUD ARRIVAL TIME.AL203 


DO 350 III = 1,8 


. S4203620 

S4203630 
S4203640 
S4203650 
S4203660 
S4203670 
S4203680 
S4203690 
S4203700 
S4203710 
S4203720 
S4203730 
S4203740 
S4203750 
CONS4203760 
S4203770 
S4203780 
S4203790 
S4203800 
S4203810 
S4203820 
S4203830 
S4203840 
S4203850 
S4203860 
S4203870 
S4203880 
S4203890 
S4203900 
S4203910 
S4203920 
S4203930 
S4203940 
S4203950 
S4203960 
S4203970 
S4203980 
S4203990 
S4204000 
S4204010 
S4204020 
S4204030 
S4204040 
S4204050 
S4204060 
S4204070 
S4204080 
S4204090 
S4204100 
S4204110 
S4204120 
S4204130 
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360 

370 


380 

390 


350 BUFDIS(III) = 0.0 

BUFDIS(4) = PASTIM(l) 

BUFDIS(8) = AMAX1(TIMALA*TIMI,0.0) 

CLDTIM(l) = PASTIM(2) 

CLDTIM(2) = TIMDLA*TIMI 
IF(NSOCS.EQ. 0) GOTO 370 
STORE GAS RESULTS. 

DO 360 III = l.NSOGS 
DO 360 J = 1,3 

BUFDIS(J) = BUFDIS(J) + CD(III,J) 

IF(MS02 .EQ. 0) GOTO 490 
STORE AL203 RESULTS. 

DO 380 III = 1,NS02 
DO 380 J = 5,7 

BUFDIS(J) = BUFDIS(J) + CD(III,J-1) 

GOTO 490 
CONTINUE 

S Ca2l CHIR to FI«) TOCATIOH . VAtOE OF 

maximum gas results. 

CALL CHIR(CD,YPI, SIGYI,NSOGS,CDMAX,YMCDL) 

SAVE MAXIMUM VALUE & LOCATION IN ARRAYS. 

DO 400 J = 1,3 

IF(CDMAX(J) .LE. 0.0) GOTO 400 
A1 = YMCDL(J) 

RANGE (IXS.J) = SQRT(X0*X0+A1*A1) 

RADI CONVERTS RADIANS TO DEGREES. 

A1 = YO + ATAN2(A1,X0P)*RADI 
IF(A1 .GT. 360.0) A1 = Al - 360.0 
IF(A1 .LE. 0.0) Al = Al + 360.0 
BEARNG (IXS , I) ~ Al 
VALUES (IXS.J) = CDMAX(J) 

SIGYBR(IXS,J) = AVGSY(1)/NSGYGS 
CONTINUE 

CLDTIM(l) = PASTIM(l) 

CLDTIM(2) = PASTIM(2) 

IF(.NOT.GRVSET) GOTO 490 

SmE Server bourdarv layer and "hidden” boundary 

FOR AL203 VALUES. 

CALL CR0SS(YPI(1,2) ,NS02) 

DO 420 I = 1,NS02 

SJi’cHk^CD(l"i!Ymi ,2) .SIGYI(1.2) , NS02 , CDMAX .YMCDL) 
S-Ba5k Soic GO BACK AND CALCULATE EXACT AL203 RESULTS 
AT MAXIMUM LOCATION (YMCDL(l)). 

LOOP = 1 

YO = YMCDL(l)/XOP*RADI 
GOTO 10 

LvE^MAXIMUM VALUE & LOC.4TION IN ARRAYS. 

Al = 0.0 


400 

410 


C* 


420 


C* 

C* 


430 


C* 


S4204140 

S4204150 

S4204160 

S4204170 

S4204180 

S4204190 

S4204200 

S4204210 

S4204220 

S4204230 

S4204240 

S4204250 

S4204260 

S4204270 

S4204280 

S4204290 

S4204300 

S4204310 

S4204320 

S4204330 

S4204340 

S4204350 

S4204360 

S4204370 

S4204380 

S4204390 

S4204400 

S4204410 

S4204420 

S4204430 

S4204440 

S4204450 

S4204460 

S4204470 

S4204480 

S4204490 

S4204500 

S4204510 

S4204520 

S4204530 

S4204540 

S4204550 

S4204560 

S4204570 

S4204580 

S4204590 

S4204600 

S4204610 

S4204620 

S4204630 

S4204640 

S4204650 


440 
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DO 450 I = 1.NS02 
450 A1 = A1 + CD(I,J) 

IF(A1 .LE. 0.0) GOTO 460 
RANGE(IXS,J) = XO 

IF(YO .GT. 360.0) YO = YO - 360.0 
IF(YO .LE. 0.0) YO = YO + 360 0 
BEARNG(IXS,J) = YO 
VALUES(IXS, J) = A1*QC0NV(4) 
SIGYBR(IXS, J) = AVGSY(2)/NSGYAL 
CLDTIM(3) = AELAXl (TIMALA*TIMI ,0. 0) 
CLDTIM(4) = TIMDLA*TIMI 
CONTINUE LOOP-BACK LOGIC. 

460 IF(LOOP .NE. 1) GOTO 470 
LOOP = 2 
J = 5 


C 


IF(ABS(YMCDL(2)-YMCDL(D) .lt 
J = 6 

IF(ABS(YMCDL(3)-YMCDL(1)) .LT. 
YO = YMCDL(2)/XOP*RADI 
GOTO 10 

470 IF(LOOP .NE. 2) GOTO 480 
LOOP = 3 
J = 6 

IF(ABS(YMCDL(3)-YMCDL(2)) .LT 

if(abs(ymcdl(3)-ymcdl(D) .lt! 

YO = YMCDL(3)/X0P*RADI 
GOTO 10 
480 CONTINUE 


l.E-3) GOTO 440 
I.E-3) GOTO 440 


l.E-3) GOTO 440 
l.E-3) GOTO 480 


C* 

C 


RETURN 


490 CONTINUE 

(BEARNG(IXS.J), J=l,6) , (VALUES (IXS.J) ,J=1,6) 

9004 F0RMAT(39H NSGYAL,NSGYGS,NS0URC(1-2) .NSOGS IXS = 6TS/ 

1 26H AVGSY(l-2),CLDTIM(l-4) = Je12.6/12H^ 7/ 

2 14H BEARNG(1-6) =,6E14.7/14H VALUES(l-6) =,6E14 7) 

RETURN ^ ,o£.i4./; 

END 


S4204660 

S4204670 

S42046S0 

S4204690 

S4204700 

S4204710 

S4204720 

S4204730 

S4204740 

S4204750 

S4204760 

S4204770 

S4204780 

S4204790 

S4204800 

S4204810 

S4204820 

S4204830 

S4204840 

S4204850 

S4204860 

S4204870 

S4204880 

S4204890 

S4204900 

S4204910 

S4204920 

S4204930 

S4204940 

S4204950 

S4204960 

S4204970 

S4204980 

S4204990 

S4205000 

S4205010 

S4205020 

S4205030 

S4205040 

S4205050 


i 
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I 



c- 

c 

c 

c 

c 

c 

c 


SUBROUTINE CHIR(CD,YPI,SIGYT,NSOURC,CDIM,YMCDL^ 

, UPDATE: 8213 SOURCE: 16 DEC 81 


THIS SUBROUTINE CALCULATES THE MAXIMUM CENTERLINE 
CONCENTRATION AND DOSAGE ALONG THE YBAR AX . 


dimension CD(50.1).SIGYI(1).YPI(1),CDMAX(3),YMCDL(3),YCHI(3) 

DATA NCAT /3/ 


DO 10 I = l.NCAT 
10 CDMAX(I) =0.0 

IF(NS0URC.EQ. 1) GO TO 40 
DO 30 I=1,NS0URC-1 
, DO 30 J=I+l,NSOURC 

if(ypi(i).gt.ypi(j)) go to 30 
TMP1=YPI(I) 

YPI(I)=YPI(J) 

ypi(j)=tmpi 

tmpi=sigyi(i) 

SIGYI(I)=SIGYI(J) 

sigyi(j)=tmpi 
DO 20 K = l.NCAT 
TMPl = CD(I,K) 

CD(I.K) = CD(J.K) 

20 CD(J,K) = TMPl 
30 CONTINUE 
40 CONTINUE 
T 1 

CALCULATE THE NUMBER OF SOURCES IN A GROUP 

50 SMIN=SIGYI(ISTR) 

I=ISTR 

60 IF(I.GT.NSOURC) go to 160 
IF(I.EQ.NSOURC) GO TO 70 
J=I+1 

tmpi=ypi(i)-ypi(J) 

TMP2=1 . 18* (SIGYI (I)+SIGYI(J) ) 

IF(TMP1 .GT.TMP2) GO TO 70 
1 = 1+1 
GO TO 60 
70 CONTINUE 

SMIN=SIGYI(ISTR) 

IF(ISTR.EQ.NSOURC) GO TO 90 
IF(ISTR.EQ. I) GO TO 90 
DO 80 M=ISTR+1,I 

80 SMIN=AMIN1 (SHIN, SIGYI (M)) 

90 YINC=.08*SMIN 
YY=YPI(ISTR) 

100 DO no J = l.NCAT 


S4300000 
S4300010 
— S4300020 
S4300030 
S4 300040 
S4300050 
S4300060 
- S4300070 
S4300080 
S4300090 
S4300100 
S4300110 
S4300120 
S4300130 
S4300140 
S4300150 
S4300160 
S4300170 
S4300180 
S4300190 
S4300200 
S4300210 
S4300220 
S4300230 
S4300240 
S4300250 
S4300260 
S4300270 
S4300280 
S4300290 
S4300300 
S4300310 
S4300320 
S4300330 
S4300340 
S4300350 
S4300360 
S4300370 
S4300380 
S4300390 
S4300400 
S4300410 
S4300420 
S4300430 
S4300440 
S4300450 
S4300460 
S4300470 
S4300480 
S4300490 
S4300500 
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110 YCHI(J) =0.0 

TF(YY.LT.YPKI)) go to 150 
DO 130 M=l,NSOURC 
EX=(YY-YPI(M))/SIGYI(M) 

EX = TEXP(EX) 


IF(EX .LE. 0.0) GOTO 130 
DO 120 J = l.NCAT 
120 YCHI(J) = YCIII(J) + CD(M,J)*EX 
130 CONTINUE 


DO 140 J = l.NCAT 

IF(YCHI(J) .LT. CDMAX(J)) GOTO 140 
CDMAX(J) = YCHI(J) 

YMCDL(J) = yY 
140 CONTINUE 
YY=YY-YINC 
GO TO 100 
150 CONTINUE 
ISTR=I+1 


GO TO 50 

160 DO 170 J = l.NCAT 
170 IF(CDMAX(J) .LE. 0.0) YMCDL(J) 
RETURN 
END 


0.0 


S4300510 

S4300520 

S4300530 

S4300540 

S4300550 

S4300560 

S4300570 

S4300580 

S4300590 

S4300600 

S4300610 

S4300620 

S4300630 

S4300640 

S4300650 

S4300660 

S4300670 

S43O068O 

S4300690 

S4300700 

S4300710 

S4300720 

S4300730 
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REEDM SOURCE MODULE &RPDPM 


FTKA 

PROGRAM RPDPM(5) 
, , UPDATE: 8213 


SOURCE 


02 APR 82 LOCATION 


KSC 


ORGANIZATION: H. E. CRAMER CO., INC. 

WORK FOR: DR. J. B. STEPHENS (ES84) 

PROGRAM CODE: RPDPM 

PROGRAM DESCRIPTION: 

THIS PROGRAM CALCULATES THE GROUND-LEVEL DEPOSITION DUE TO 
PRECIPITATION SCAVENGING FOR THE MEAN WIND DIRECTION RADIAL AT 
EVERY KILOMETER DOWNWIND FROM THE LAUNCH SITE. FOR THE HCL 
SPECIES, THE AMOUNT OF ACID IS ALSO COMPUTED. 


C 

Cc 

c**** BEGIN COMMON AREA 

04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, I VHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE, IPRINT, SI GMAR, SIGNER, LSITE.BOTLAY. 

ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE ( 3) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) .CISO(IO) .DISO(IO) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12),DBAR(20) 

C COUNTERS , FLAGS , GENERAL AND INDEX VARIABLES 

LOGICAL I SNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS , MODELS 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK.QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 
SIGZ , I SNDFO , CRT , LAYTOP (3) , ITDU, KEEP 
, MIXING , MAXDEP , LAYBOT (3) 

, ALTS V , BATCH , CL ( 1 4 ) , CS ( 1 0) , GASSET , I AGAIN , 
ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , 
MINUS 1 ,MINUS9 ,MINS 1 ,MINS9 , 
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M0DEL4, MODELS, M0DEL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S4400500 
RT(24),TPROPC,IDXRT S4400510 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S4400520 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S4400530 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S4400540 

. CLRLNE , INSLNE , DELINE S4400550 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,IN\TiF(2) , S4400560 

INVNDR(2),ULINE(2), S4400570 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN, CURLFT.CLRDSP ,84400580 
CLRLNE, INSLNE, DELINE, S4400590 

IESCAJC3) .NULL, IBLNK, S4400600 

IPAR(5),ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S4400610 

C ^—VEHICLE PARAMETERS S4400620 

COMMON /VCLPR/ VPAR(17) S4400630 

C time PARAMETERS S4400640 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S4400650 

LDAY,LYEAR,ISM0N(2),JM0N(2)',LM0N(2),LSDT(2) S4400660 

c SOUNDING/FORCAST meteorological data (initial LEVELS) S4400670 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S4400680 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S4400690 

C LAYER PARAMETERS S4400700 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S4400710 

SIGYO(29) S4400720 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S4400730 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S4400740 

C CALCULATED NEW LAYER PARAMETERS S4400750 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S4400760 
SPEEDN(32) S4400770 

C CONVERSION FACTORS S4400780 

COMMON /CNVRT/ QCONV(4) .QPDEPH S4400790 

^ S4400800 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S4400810 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S4400820 

C READ/TOITE BUFFER S4400830 

C -A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S4400840 ’ 

C************************************-a**********************************s4400850 
^ S4400860 

C EQUIVALENCE STATEMENTS S4400870 

EQUIVALENCE(IIU,IPAR(D) , (lOU, IPAR(2)) , (IPUl ,IPAR(3) ) S4400880 

, (IPU2,IPAR(4)) , (IPU3,IPAR(5)) S4400890 

EQUIVALENCE (MAXDEP , GRVSET) , (IFRMT(l) .IFRMTl) S4400900 

C S4400910 

C**** END OF COMMON AREA ****S4400920 

CC S4400930 

LOGICAL IBATCH S4400940 

C S4400950 

DIMENSION IPL(12) ,MILK(3),IER(2) S4400960 

DIMENSION DISBUF(14, 1) ,MPTDLB(8,2) ,ZMET(3,2) ,WDHOLD(4,3) ,\JDOUT(9) S4400970 
DIMENSION RANGE (30 , 1 ) , BEARNG (30 , 1 ) , SIGYBR(30 , 1 ) , VALUES (30 , 1 ) S4400980 

1 ,CDAMXS(1),PEAKS(2,1),IDDISR(10,60) S4400990 

C S4401000 

EQUIVALENCE (PLUS, DISBUF, RANGE) . (PLUS(181) , BEARNG) , S4401010 
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iiiUi iii 



on non 


1 (PLUS(361) .SIGYBR) . (PLUS(541) .CDAMXS) . (PLUS (547) .VALUES) , 

2 (PLUS(727) .PEAKS) , (ERR.IER) 

DATA IPL /2H H.2HCL.2H . 2H C.2H02.2H ,2H C.2HO .2H .2HAL.2H20. 

1 2H3 / 

DATA NXS.WTMOL / 30, 36. 46/ 

DATA MILK 72.3,1/ 

DATA MPTDLB /2H T , 2HIM, 2HE- , 2H-D, 2HEP , 2HEN, 2HDE. 2HNT, 

1 2HMA,2HXI,2HMU,2HM ,2HPO,2HSS.2HIB,2HLE/ 

DATA IBATCH /.FALSE./ 

DATA JVERSN/8213/ 


IF (IVERSN .NE. JVERSN) CALL L0ADS(-1 .0,0. 0,0, BATCH) 
C*** INITIALIZE. 

JER = 0 


C 

C 


IFdRUN .EQ. 4) VJRITE(I0U,9014) 

PH CONVERSION FACTOR. 

QPDEPH = 1 . 0/ (RAINRT*25 . 4*WTM0L*DURAT) 

IF(MAXDEP) QPDEPH = QPDEPH*DURAT 
CLEAR WORK SPACE. 

DO 10 I = 1,900 
10 PLUS (I) =0.0 
DO 20 I = 1,4 
20 QCONV(I) = 1.0 

INITIALIZE BOUNDARY LAYERS PARAMETERS. 

NLK = 1 

IF(HM(2) .GT. 0.0) NLK = 3 

KXS = NXS - 1 

DO 30 I = 1,2 

ZMET(I.l) = ALT(LAYBOT(D) 

30 ZMET(I,2) = ALT(LAYT0P(I)+1) 

ZMET(3,1) = ALT(LAYBOTd)) 

ZMET(3,2) = ALT(LAYT0P(2)+1) 

MAXLAB = 1 

IF(MAXDEP) MAXLAB = 2 

CHECK SEGMENT ENTRY POINT. 

IF(NNNTRY .EQ. 10) GOTO 180 

! ! ! ! H.E.C COPY ONLY. 

IF (BATCH) GO TO 60 

40 WRITE (ICU,9031) INVNDR, INV,OFF,ULINE,OFF 
READ (IIU,9032) IFRMTl 

IF (IFRMTl. EQ.INJ. OR. IFRMTl. EQ.INOJ) GO TO 170 

IF (IFRMTl. EQ.IBLNK. OR. IFRMTl. EQ.IYSJ.OR.IFRMTl.EQ.IYESJ) GO TO 

WRITE (ICU.9001) INV.OFF.O.O 
GO TO 40 

50 WRITE (ICU,9018) CURSUP , CLRLNE 
60 CONTINUE 
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C ! ! ! ! 
C 
C 
C 

C*** 

c 


BEGIN LOOP OVER RANGES. 


DO 90 IXS =2,30 
XT = (IXS-1)*1000.0 

IF( .NOT. BATCH) URITE(ICU,9016) CURSUP,MDLNAM,INV,XT,OFF 
C* CALL SUBROUTINE IffllCH COMPUTES WASHOUT DEPOSITION. 

CALL WASHT(NLK,XT,YT, IXS, UDHOLD, .FALSE. ) 

C* FIND MAXIMLT-I VALUES AND LOCATIONS OVER ALL RANGES 

DO 80 ILK = 1,NLK 
C PH. 

IF(CDAMXSdLK) .GT. VALUES (IXS , ILK) ) GOTO 70 

CDA>KS(ILK) = VALUES (IXS, ILK) 

PEAKS (1, ILK) = RANGE (IXS, ILK) 

PEAKS(2,ILK) = BEARNG(IXS.ILK) 

C AL203. 

70 II = ILK + 3 

IF(CDA>KS(I1) .GT. VALUES (IXS, II) ) GOTO 80 
CDAPKSdl) = VALUES (IXS, II) 

PEAKSd.Il) = RANGE(IXS,I1) 

PEAKS(2,I1) = BEARNG(IXS,I1) 

80 CONTINUE 
90 CONTINUE 

IF(. NOT. BATCH) WRITE(ICU, 9017) CURSUP.CLRDSP.BLNKNG.OFF 

c 

C*** LOOP OVER MAJOR BOUNDARIES. 

C 

DO 160 ILK = l.NLK 
NILK = ILK 

IF(NLK .GT. 2) NILK = MILK(ILK) 

JILK = NILK + 3 
IF(ILK .GT. 2) GOTO 100 
IBOT = LAYBOT(ILK) 

ITOP = LAYTOP(ILK) 

GOTO no 

100 IBOT = LAYBOT(l) 

ITOP = LAYTOP(2) 
no CONTINUE 

c 

C** LOOP OVER SPECIES. 

C 


DO 150 J = 1,4 

IF(IPLLNT(J) ,NE. 1 .AND. IPLLNT(J) .NE. 4) GOTO 150 
KDX = IPLLNT(J)*3 - 3 
WRITE (IOU.9002) I VERSN , LOCATN , MDLNAM 
WRITE(IOU,9003) 

WRITE(TOU,9005) (IPL(KDX+K) ,K=1,3) .TITLE, ALT (IBOT) ,ALT(ITOP+l) 

1 ISTIME,LSDT, ISDAY , ISMON, ISYEAR,LTrME, LSDT,LDAY,LMON,LYEAR, 

2 JTIME , LSDT , JDAY , JMON , JYEAR 
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c 

c* 

c- 


130 

c 

c** 

c 


PRINT HEADING DEPENDING ON WASHOUT DEPOSITION AND SPECIES OPTION. 
TOITE(IOU,9006) (MPTDLB(K.MAXLAB) ,K=1,A) , (MPTDLB(K,MAXLAB) ,K=4,8) 
IF(IPLLNT(J) .EQ. 1) WRITE(IOU, 9009) 

IFUPLLNT(J) .EQ. 4) WRITEaOU,9008) 

WRITE (lOU, 9007) 

BEGIN LOOP OVER RANGES. 

DO 130 IXS =2,30 
IF(IPLLNT(J) .EQ. 1) GOTO 120 
PRINT AL203. 

A1 = VALUES ( IXS, JILK) 

IF (A1 .LE. 0.0) GO TO 130 

WRITE(IOU,9010) RANGE (IXS, JILK) ,BEARNG (IXS, JILK) ,A1 
GOTO 130 

COMPUTE & PRINT PH FOR HCL. 

120 CONTINUE 

A1 = VALUES ( IXS, NILK) 

IF(A1 .LE. 0.0) GOTO 130 

PDEPPH = AMIN1(1.0,AMAX1(A1,1.E-14)) 

PDEPPH = -ALOGT (PDEPPH) 

WRITE(IOU,9010) RANGE (IXS, NILK), BEARNG( IXS, NILK), PDEPPH 
CONTINUE 

PRINT MAXIMUM VALUES FOUND OVER ALL RANGES. 

WRITE(IOU,9011) 

IF(IPLLNT(J) .NE. 1) GOTO 140 
PH. 

CDAMXS(NILK) = AMINl (1 . 0 ,AMAX1 (CDAIKS(NILK) , 1 .E-14)) 

CDAMXS(NILK) = -ALOGT (CDAMXS (NILK) ) 

WRITE(IOU,9012) CDAMXS(NILK) ,PEAKS(1, NILK) ,PEAKS(2, NILK) 

GOTO 150 
AL203. 

140 WRITE(IOU,9012) CDAMXS(JILK) ,PEAKS(1 , JILK) ,PEAKS(2, JILK) 

150 CONTINUE 
160 CONTINUE 

IF (.NOT. BATCH) WRITE(ICU,9018) CURSUP , CURLFT , CLRDSP 

170 CONTINUE 

NNNEST = 3 
NNNTRY = 4 
CALL REEDM 


180 lER = 0 

IF (.NOT. BATCH) GOTO 190 
READ(IIU,9013) IDMY 
GOTO 200 

190 WRITE(ICU,9019) INVNDR,INV,OFF, (ULINE,OFF,I=l ,2) 
CALL IFNBR(IFRMT, 12,IER,IIU) 
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ID^^Y = IFRMT(l) 

IF(IDMY.EQ.MINUS9) GOTO 620 
IF (IDMY.NE. MINUS 1) GOTO 200 
JER = JER+1 

IF (JER .GT. 1) GO TO 610 
imiTE (ICU.9030) 

GO TO 190 
200 JER = 0 

IF(IDMY .EQ. INJ .OR. IDMY .EQ. INOJ) GOTO 630 
IFdDMY.EQ.IBLNK .OR. IDMY. EQ. lYSJ.OR. IDMY. EQ. lYESJ) GOTO 220 
IF (lER .EQ. 0) GO TO 210 
WRITE (ICU.9001) INV, OFF, 23,0 
IF (BATCH) GO TO 610 
GO TO 190 
210 CONTINUE 

IBATCH = .TRUE. 

IIUTMP = IIU 
CALL CODE (2) 

READdDMY,*) IIU 
WRITE(ICU,9015) lESCAJ 

C 

C*** BEGIN DISCRETE RECEPTOR CALCULATIONS. 

C 

220 NXS = 0 
LINE = 100 
230 CONTINUE 

DO 240 I = 1,10 
240 IFRMT(15+I) = IBLNK 

IF (.NOT. BATCH .AND. .NOT. IBATCH) GOTO 260 
IF(NXS .GT. 59) GOTO 460 
ERR = EXEC(l,IIU,IFRMT,-80) 

IF(IER(2) .LE. 0) GOTO 460 
CALL IFNBR(IFRMT,-26,IER,IIU) 

IF (lER .EQ. 0) GO TO 250 
WRITE (ICU,9001) INV, OFF, 23,1 
GO TO 230 
250 CALL C0DE(30) 

READdFRMT,*) XT,YT 
IF(XT .LT. 0.0) GOTO 460 
GOTO 320 

260 WRITE(ICU,9020) CURSUP,CLRDSP 
270 CALL IFNBR(IFRMT,26,IER,IIU) 

IF (lER .EQ. 0) GO TO 290 
280 WRITE (ICU,9001) INV, OFF, 23,1 
WRITE dCU,9020) IBLNK, IBLNK 
GO TO 270 
290 CALL CODE(80) 

READ (IFRMT,*) XT,YT 
IF (XT .EQ, MINSl) GO TO 300 
IF (XT .EQ. MINS9) GO TO 620 
IF (XT .GE. 0.0) GO TO 310 
GO TO 280 


S4402580 

S4402590 

S4402600 

S4402610 

S4402620 

S4402630 

S4402640 

S4402650 

S4402660 

S4402670 

S4402680 

S4402690 

S4402700 

S4402710 

S4402720 

S4402730 

S4402740 

S4402750 

S4402760 

S4402770 

S4402780 

S4402790 

S4402800 

S4402810 

S4402820 

S4402830 

S4402840 

S4402850 

S4402860 

S4402870 

S4402880 

S4402890 

S4402900 

S4402910 

S4402920 

S4402930 

S4402940 

S4402950 

S4402960 

S4402970 

S4402980 

S4402990 

S4403000 

S4403010 

S4403020 

S4403030 

S4403040 

S4403050 

S4403060 

S4403070 

S4403080 

S4403090 


196 



o o n 


300 WRITE(ICU,9015) lESCAJ , lESCAJ 
GOTO 180 

310 WRITE(ICU,9018) (CURSUP, CURLFT, CLRDSP, 1=1 , 2) 

C 

c** MAKE 3 CALCULATIONS PER DISCRETE RECEPTOR. 

C • ' 

320 YTl = YT - 10.0 

IF(YT1 .LE. 0.0) YTl = YTl + 360.0 
NXS = NXS +1 
DISBUF(l.NXS) = XT 
DISBUF(2,HXS) = YTl 
DO 330 J = 1,10 

330 IDDISR(J,NXS) = IFRMT(15+J) 

DO 340 J = 1,3 

CALL WASHT (NLK , XT , YT 1 , NXS , WDHOLD ( 1 , J ) , . TRUE . ) 

YTl = YTl + 10.0 

IF(YT1 .GT. 360.0) YTl = YTl - 360.0 
340 CONTINUE 
C 

C** SAVE RESULTS IN BUFFER. 

C 

L = 2 

DO 360 J = 1,3 
DO 350 K = 1,4 

350 DISBUF(L+K,NXS) = TOH0LD(K,J) 

360 L = L + 4 

IF (BATCH) GOTO 230 

** DISPLAY DISCRETE RECEPTOR RESULTS. 

IF(LINE .LT. 22) GOTO 370 

■LINE =5 * . X , .X 

WRITE(ICU,9021) (MPTDLB (I ,MAXLAB) ,1=1,8) , (ZMET(I,1) ,ZMET(I,2) , 

1 1=1, NLK) 

WRITE(ICU,9033) 

370 CONTINUE 

LINE = LINE + 3 
WRITE(ICU,9022) XT,YT 
DO 420 JJ = 1,4 
IP = IPLLNT(JJ) 

IF(IP .NE. 1 .AND. IP .NE. 4) GOTO 420 
KDX = IP*3 - 3 
K = 0 

IF(IP .EQ. 4) K = 2 
L = 0 

DO 380 I = 1,2 

DO 380 J = 1,3 

L = L + 1 

380 WDOUTCL") = 17DHOLD(I+K, J) 

DO 390 I = 1,3 

L = L + 1 

390 UDOUT(L) = TOOUT(I) + WDOUT(I+3) 
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IF(IP .NE. 1) GOTO 410 
DO 400 I = 1,3*NLK 

A1 = AMIN1(1.0,AMAX1(WD0UT(I),1.E-14)) 
400 WDOUT(I) = -ALOGT(Al) 

410 CONTINUE 


LINE = LINE + 1 

Lj(\ (IPL(KDX+J) ,J=1 ,3) ,OFF, (UDOUT(J) ,J=1,3*NLK) 

HZU CONTINUE 

IF(NXS .LT. 60) GOTO 430 
WRITE(ICU,9024) 

GOTO 460 

430 IF(IBATCH) GOTO 230 

WRITE ( ICU , 9025 ) INVNDR , INV , OFF , ULINE , OFF 

IDMY = IBLNK 

READ(IIU,9013) IDMY 

IF(IDIfY .EQ. MINUS9) GOTO 620 

IFdDlDf .NE. MINUS 1) GOTO 440 

WRITE(ICU,9015) lESCAJ 

GOTO 180 


440 IF(IDMY. EQ. IBLNK. OR. IDMY. EQ. lYSJ. OR. IDMY.EQ. lYESJ) 
IF (IDMY. EQ.INJ. OR. IDMY. EQ.INOJ) GO TO 450 
WRITE (ICU, 9001) INV. OFF, 23, 2 
GO TO 430 

450 WRITE(ICU,9018) CURSUP, CURLFT.GLRDSP 
C WRITE BLANK LINE. 

WRITE(ICU,9013) IBLNK 
C 


GO TO 230 


C** PRINT DISCRETE RECEPTOR RESULT. 
C 


460 CONTINUE 

IF(.NOT.IBATCH) GOTO 470 
IIU = IIUTMP 
WRITE(ICU,9013) IBLNK 
470 DO 600 ILK = l.NLK 
DO 590 JJ = 1,4 
IP = IPLLNT(JJ) 

IF(IP .NE. 1 .AND. IP .NE. 4) GOTO 590 

KDX = IP*3 - 3 

WDMAX =0.0 

YTMAX =0.0 

KKMAX = 1 

LINE = 100 


DO 570 KK = l.NXS 
IF(LINE .LT. 53) GOTO 500 
LINE = 15 

WRITE ( lOU , 9 00 2 ) IVERSN , LOCATN , MDLNAM 
WRITE(IOU,9004) 

WRITE(IOU,9005) (IPL(KDX+J) , J=1 , 3) ,TITLE,ZMET(ILK, 1) ,ZMET(ILK, 2) 

1 ISTIME.LSDT, ISDAY , ISMON, ISYEAR,LTIME,LSDT,LDAY,LMON,LYEAR 

2 jtime,lsdt,jday,jmo'n,jyear 

WRITE(IOU,9026) (MPTDLB(K.MAXLAB) ,K=1 ,4) , (MPTDLB(K,ILAXLAB) ,K=4 6 
IF(IP .NE. 1) GOTO 480 
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WRITE (lOU, 9027) 

K = 0 
GOTO 490 

480 WRITE(IOU,9028) 

K = 2 

490 ’WRITE(IOU,9007) 

500 CONTINUE 

XT = DISBUF(l.KK) 

YTl = DISBUF(2,KK) 

L = 2 

DO 560 J = 1,3 
IF(ILK .EQ. 3) GOTO 510 
A1 = DISBUF(L+K+ILK,KK) 

GOTO 520 . 

510 A1 = DISBUF(L+K+1,KK) + DISBUF(L+K+2 ,KK) 

520 IF(IP .NE. 1) GOTO 530 

A1 = AMIN1(1.0,AMAX1(A1,1.E-14)) 

A1 = -ALOGT(Al) 

530 IF(A1 .LT. 0.0005) GOTO 550 
IF(A1 .LT. WDMAX) GOTO 540 
TOMAX = A1 
YTMAX = YTl 
KKMAX = KK 
540 LINE = LINE + 1 

IF(J.NE.2) WRITE(I0U,9029) (IBLNK,I=1 , 10) ,XT,YT1 ,A1 
IF(J.EQ.2) WRITE(IOU,9029) (IDDISR(I ,KK) ,1=1 , 10) ,XT,YT1 ,A1 
550 YTl = YTl + 10.0 

IF(YT1 .GT. 360.0) YTl - YTl - 360.0 
560 L = L + 4 
570 CONTINUE 

IF(IP .NE. 1) GOTO 580 

WDMAX = AMIN1(1.0,AMAX1 (WDMAX, l.E-14)) 

WDMAX = -ALOGT(WDMAX) 

580 CONTINUE 

WRITE (IOU,9011) 

WRITEUOU,9012) WDMAX, DISBUF(1 .KKMAX) .YTMAX 
590 CONTINUE 
600 CONTINUE 
GOTO 630 
C 

C*** ERROR EXIT. 

C 

610 lERROR(l) = MINSl 
GOTO 630 

620 lERROR(l) = 1 

C , 

630 NNNEST =1 
NNNTRY = 3 
CALL REEDM 
C 

CF** FORMAT STATEMENTS . 

CF. 
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9001 FORMAT (2A2.38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2,6H REG. S4A04660 

*,I2,1H. ,11/) S4404670 

9002 F0RMAT(1H1,38(2H**)/1X,8(2H**),44X,8(2H**)/ S4404680 

1 1X,8(2H**) ,3X,13HREEDM UPDATE, 15 , 1 IH LOCATION , 2A2 ,8X,8(2H**) / S4404690 

2 IX, 8(2H**) ,4X, 12A2.6H MODEL, 10X,8(:2H**)/ S4404700 

3 1X,8(2H**) ,44X,8(2H**)/1X,38(2H**)/) S4404710 

9003 F0RMAT(1X,8(2H**) ,7X,31HMAXIMUM CENTERLINE CALCULATIONS, 6X,8(2H**)S4404720 

■ *) S4404730 

9004 F0RMAT(1X,8(2H**) ,7X,30HDISCRETE RECEPTOR CALCULATIONS, 7X, 8(2H**) )S4404740 

9005 FORMAT (/27X,4HFOR ,3A2,15HAT GROUND-LEVEL/ 15X, 16HD017NUIND FROM A ,54404750 

1 14A2,7H LAUNCH/4X,40HCALCULATIONS APPLY TO THE LAYER BETITEEN , S4404760 

2 F6.1,5H AND ,F6.1,7H METERS //9X, 3 IHTHE METEOROLOGICAL DATA IS FROS4404770 

3M,I5,2A2,I4,1X,2A2,14/19X,16H LAUNCH TIME IS, 110, 2A2 , 14 , IX, 2A2 , I4S4404780 
4/15X,20HTIME OF EXECUTION IS , 110, 2A2, 14 , IX, 2A2, 14//) S4404790 

9006 FORMAT(46X,3A2,Al/45X,Rl,4A2/46X,7HWASHOUT/ S4404800 

1 15X,5HRANGE,9X,7HBEARING,8X,10HDEPOSITION) . S4404810 

9007 FORMAT(38(2H— )) S4404820 

9008 FORMAT(13X,8H(METERS) ,7X,9H(DEGREES) ,7X,10H(MG./SQ.M)) S4404830 

9009 FORMAT03X,8H(METERS) ,7X,9H(DEGREES) ,10X,4H(PH)) S4404840 

9010 F0RMAT(F21.3,F15.3,F17.3) S4404850 

9011 FORMAT (//53X, 1 6HRANGE BEARING/5 IX, 9 (2H—)) S4404860 

9012 F0RMAT(F15.3,31H IS THE PEAK WASHOUT DEPOSITION, F13. 3 ,F10. 3) S4404870 

9013 FORMAT(A2) S4404880 

9014 FORMAT(50H1DIAGNOSTICS FOR WASHOUT DEPOSITION PROGRAM, RPDPM) S4404890 

9015 FORMAT (2A2,A1) S4404900 

9016 FORMAT(A2,12A2,30H MODEL IS PROCESSING RANGE AT ,2A2,F7. 1 ,2A2, S4404910 

1711 METERS) S4404920 

9017 F0RMAT(2A2,10X,2A2,8HPRINTING,2A2) S4404930 

9018 FORMAT(3A2) S4404940 

9019 FORMAT(46H DO YOU WISH DISCRETE RECEPTOR CALCULATIONS? (,2A2,1HY, S4404950 

1 2A2,2HES,2A2,lH,,2A2,lHN,2A2,2HO,,2A2,3HLU//,2A2,16H OF DATA FILE) S4404960 
2;_) S4404970 

9020 FORMAT(2A2,68H ENTER DISCRETE RECEPTOR LOCATION RELATIVE TO LAUNCHS4404980 

1 PAD. A 20 CHAR./52H COMMENT MAY BE ENTERED STARTING UNDER THE ASTS4404990 
2ERISK. ,10X,1H*/33H RANGE (METERS) ,BEARING(DEGREES) :_) S4405000 

9021 FORMAT (1X,37(2H**)/2H *, 19X,8A2, 19H WASHOUT DEPOSITION, 18X, IH*/ S4405010 

*7H LAYERS, F7.1.3H TO,F7.1,2H *,F10.1,3H TO,F8.1,4H *,F10.1,3H TOS4405020 

*,F8.1,3H *) S4405030 

9022 FORMAT(/27H DISCRETE RECEPTOR RANGE =,F8.1,11H, BEARING =,F6.1) S4405040 

9023 FORMAT (32X,3H** ,4A2,A1 ,2A2,3H **/2H *,2F7. 1 ,F8. 1 ,2(2H *,F8. 1 ,F7. S4405050 

*1,F8.1)) S4405060 

9024 FORMAT(63H A MAXIMUM OF 60 DISCRETE RECEPTOR LOCATIONS HAVE BEEN ES4405070 

1NTERED./29H THIS SECTION IS TERMINATED ._) S4405080 

9025 FORMAT(58H DO YOU WISH TO ENTER ANOTHER DISCRETE RECEPTOR LOCATIONS4405090 

1 ? ( , 2A2 , IHY , 2A2 , 2HES , 2A2 , IH , , 2A2 , IHN , 2A2 , 4HO) :_) S4405 100 

9026 FORMAT(56X,3A2,Al/55X,Rl,4A2/56X,7HWASHOUT/ S4405110 

1 25X,5HRANGE,9X,7HBEARING,8X,10HDEPOSITION) S4405120 

9027 FORMAT(6X,10HIDENTIFIER,7X,8H(METERS) ,7X,9H(DEGREES),10X,4H(PH)) S4405130 

9028 FORMAT(6X,10HIDENTIFIER,7X,8H(METERS) ,7X, 911 (DEGREES) ,7.x, lOH (MG. /SQS4405 140 

l.M)) S4405150 

9029 FORMAT(1X,10A2,F10.3,F15.3,F17.3) S4405160 

9030 FORMAT (7311 REEDM WARNING 019, -1 NOT APPLICABLE, PROG. ABORTSS4405 170 
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n o 


* IF -1 TYPED AGAIN) 


S4405180 
S4405190 

!!'. ! H.E.C COPY ONLY. S4405200 

9031 FORMAT (57HDO YOU WISH MAXIMUM CENTERLINE PRECIPITATION DEPOSITIONS440521 0 
*? ( , 2A2 , IHY , 2A2 , 2HES , 2A2 , IH , , 2A2 , IHN , 2A2 ,4HO) :_) 

9032 FORMAT (A2) c/zn^/n 

C! ! ! ! S4405240 

9033 FORMAT (1X,3(24H*-10 DEG. POINT +10 DEG.),2H */lX,37(2H**)) S4405250 

S4405260 

END S4405270 
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REEDM SOURCE MODULE &RPDPN 


C 

c 

c 

c 

c 

Cc 

c**** 


FTN4 

SUBROUTINE WASHT (NLK , XO , YO , IXS , BUFDI S , DISCRT) 

. , UPDATE; 8213 SOURCE: 02 APR 82 LOCATION: KSC 


THIS SUBROUTINE CALCULATES THE MAXIMUM PRECIPITATION DEPOSITION 
FOR A GIVEN RANGE AND MAJOR BOUNDARY. 


BEGIN COMMON AREA 

04/02/82 

MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI.G.CP.MAXLEV.GAMMAI.GAMMAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, I VHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA, BETA, 

XRY , XRZ , XLRY , TIMAV , IS IG , ICALC , CALHT , 

IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,BOTLAY, 

ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE (3 ) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 

,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 

TISO(IO) ,TITLE(14),SIGPP(29),SIGLL(29),VS(20) , 
FS(20),MDLNAM(12),DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL I SNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

M0DEL4 , MODELS ,M0DEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT (3 ) 

,ALTSV, BATCH, CL(14),CS(10) .GASSET, lAGAIN, 

ICHAR (12), IDXCL, IDXCS , IERROR(5 ) . IFRMT (80) , 

MINUS 1 ,MINUS9 ,MINS1 ,MINS9 , 

M0DEL4 , MODELS , M0DEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY 
RT(24) ,TPROPC,IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR, 

TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2).ULINE(2), 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP ,84500460 
CLRLNE, INSLNE, DELINE, S4500470 

IESCAJ(3) ,NULL,IBLNK, S4500480 

IPAR (5) , ICU , lYS J, lYES J, INJ , INOJ , NAMEP (3) S4500490 
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c VEHICLE PARAMETERS S4500500 

COMMON /VCLPR/ VPAR(17) S4500510 

C time parameters S4500520 

COMMON /TIME/ JTIME, JDAY, JYEAR.IStiME.ISDAY.ISYEAR.LTIME, S4500530 

. LDAY,LYEAR,ISMON(2) , JMON(2) ,LMON(2) ,LSDT(2) S4500540 

C SOUNDING/ FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S4500550 

COMMON /FRCST/ ALT(30) ,DIR(30) , SPEED(30) ,TEMP(30) ,PRESS(30) , S4500560 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S4500570 

C LAYER PARAMETERS S4500580 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S4500590 

. SIGYO(29) S4500600 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S4500610 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S4500620 

C CALCULATED NEW LAYER PARAMETERS S4500630 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S4500640 

. SPEEDN(32) S4500650 

C CONVERSION FACTORS S4500660 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S4500670 

C S4500680 


C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S4500690 
COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S4500700 

C READ/\7RITE BUFFER S4500710 

C- A R R A Y = 2077 + 1 + 1 + 2 * 900 =* 3879S4500720 

C*********************** *********************************************** *S45007 30 


C S4500740 

C— EQUIVALENCE STATEMENTS S4500750 

EQUIVALENCE(IIU,IPAR(1)) , (IOU,IPAR(2)) , (IPU1,IPAR(3)) S4500760 

, (IPU2,IPAR(4)) , (IPU3,IPAR(5)) S4500770 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) S4500780 

C S4500790 

C**** END OF COMMON AREA ****84500800 


Co ■ S4500810 

LOGICAL DISCRT 84500820 

DIMENSION CI(100),DI(100),YPI(100),SIGYI(100),BUFDIS(1),MILK(3) 84500830 

DIMENSION VALUES(30,1),RANGE(30,1),BEARNG(30,1),SIGYBR(30,1) 84500840 

DIMENSION INDEX (2) 84500850 

EQUIVALENCE (PLUS.RANGE) , (PLUS(lSl) .BEARNG) , ^ S4500860 

1 (PLUS(361) .SIGYBR) , (PLUS(547) .VALUES) 84500870 

‘ DATA MILK /2, 3,1/ 84500880 

DATA RAD /. 01745329/, RADI/57.29578/ 84500890 

C 84500900 

C*** INITIALIZE. 84500910 

C 84500920 

XOP = XO 84500930 

IF (XOP .EQ. 0.0) XOP = 5.0 84500940 

ISTART =1 84500950 

SUMSY =0.0 84500960 

INDM = 1 84500970 

DO 10 I = 1,100 84500980 

DI(I) =0.0 84500990 

10 CI(I) = 0.0 84501000 

C 84501010 


203 


c*** 

c 


20 

C 

C 


30 


C 

c*** 

c 


c 

c** 

c 


c 

c 

c** 

c 

c 

c 

c** 

c 


BEGIN LOOP OVER MAJOR BOUNDARY LAYERS. 

S4501020 

S4501030 


DO 170 ILK = l.NLK 

S4501040 


NILK = ILK 

S4501050 


IF(NLK .GT. 1) NILK = MILK (ILK) 

S4501060 


IF (ILK .GT. 2) GOTO 20 

S4501070 


JF = NLAYS + ILK 

S4501080 


IBOT = LAYBOT(ILK) 

S4501090 


ITOP = LAYTOP(ILK) 

S4501100 


IF(.NOT.DISCRT) YO = DIRN(JF) + 180.0 

S4501110 


AVGSY =0.0 

S4501120 


GOTO 30 

S4501130 


CONTINUE 

S4501140 


COMPUTE UPPER LIMITS OF BOUNDARY LAYERS AND DISTANCE ALONG 

S4501150 


ARC FROM CENTERLINES OF BOUNDARY LAYERS AT RANGE XO. 

S4501160 


INDEX(l) = ISTART - NSOURC - 1 

S4501170 


INDEX (2) = ISTART - 1 

S4501180 

= 

DARC = (DIRN(NLAYS+1) - DIRN(NLAYS+2))*RAD*X0 

S4501190 

- 

AVGSY = SUMSY/(ISTART+NSOURC-l) 

S4501200 


NSOURC = ISTART - 1 

S4501210 


ISTART = 1 

S4501220 

t 

GOTO 120 

S4501230 

- 

CONTINUE 

S4501240 

- 

NSOURC = 0 

S4501250 


SPEEDI = 1.0/SPEEDN(JF) 

S4501260 


IF(IRUN .EQ. 4) WRITE(IOU,9003) ILK.XO.YO 

S4501270 

- 


S4501280 


BEGIN LOOP OVER METEOROLOGICAL LAYERS WITHIN MAJOR BOUNDARY. 

S4501290 



S4501300 

m 

DO no M = IBOT, ITOP 

S4501310 

1 

PDEPMX =0.0 

S4501320 


PDEPPH =0.0 

S4501330 


IF(Q(M) .LE. 0.0) GOTO 100 

S4501340 



S4501350 

i- 

CALL SUBROUTINE TO COMPUTE DOWNWIND(X) AND CROSSWIND(Y) DISTANCES. S4501360 

S4501370 


A1 = DIRN(JF)*RAD 

S4501380 


CALL COORD(Al,M,XO,YO,XS,YS,X,Y) 

S4501390 


UPWIND? 

S4501400 


IFdFLG .LT. 0) GOTO 100 

S4501410 

S4501420 


CALL SUBROUTINE TO COMPUTE SIGMAS FOR THIS MET LAYER. 

S4501430 

S4501440 


CALL SIG14A (X , M , JF , 0 , SIGAPN (M) , SIGEPN(M) ,DDIR(M) ) 

S4501450 


BAD SIGMA Y? 

S4501460 


IF(SIGYNK .LE. 0.0) GOTO 100 

S4501470 

S4501480 


COMPUTE PRIMARY TERMS. 

S4501490 



S4501500 


A1 = (X - 2.15*SIGXNK)*SPEEDI 

S4501510 


IF (TIM 1 .LT. Al) GOTO 40 

S4501520 


IFdRUN .NE. 4) GOTO 40 

S4501530 
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WRITE (lOU, 9001) XO,YO,M 
40 CONTINUE 

C 2.506628 = SQRT(2*PI) 

A2 = LAMBDA*Q(M)/(2.506628*SPEEDN(JF)*SIGYNK) 

IF(.NOT.DISCRT) GOTO 50 
C 

C** ALAT IS LATERAL TERM FOR NON-CENTERLINE CALCULATIONS. 

ALAT = Y/SIGYNK 
ALAT = -.5*ALAT*ALAT 
IF(ALAT .LT. -60.0) GOTO 100 
ALAT = EXP (ALAT) 

50 IF(SIGXNK .LE. 0.0) GOTO 100 

** COMPUTE CENTERLINE PREC. DEPOSITION (PDEPMX) AND ACID (PDEPPH) . 

IF(MAXDEP) GOTO 60 
C TIME-DEPENDENT. 

PDEPMX = -LAMBDA* (X*SPEEDI-TIM1) 

IF (PDEPMX .LT. -60.0) GOTO 100 
PDEPMX = EXP (PDEPMX) *A2 
PDEPPH = PDEP>D( 

GOTO 70 
60 CONTINUE 

C MAXIMUM POSSIBLE. 

PDEPIK = -LAMBDA*2. 15*SIGXNK*SPEEDI 
IF(PDEPMX .LT. -60.0) GOTO 100 
PDEPMX = EXP (PDEPMX) *A2 

C 837.2093 = 3600/4.3 = HOURS TO SECONDS /STANDARD DEV. 

PDEPPH = PDEPMX*837.2093*SPEEDN(JF)/SIGXNK 
70 CONTINUE 

IF(.NOT.DISCRT) GOTO 80 
PDEPPH = PDEPPH*ALAT 
PDEPMX = PDEPMX*ALAT 
C 

C*** SAVE NON-ZERO RESULTS. 

C 

80 IF(PDEPMX) 100,100,90 
90 CI(INDM) = PDEPMX 
DI(INDM) = PDEPPH 
SIGYI(INDM) = SIGYNK 
AVGSY = AVGSY + SIGYNK 
YPI(INDM) = Y 
NSOURC = NSOURC +1 
INDM = INDM + 1 
100 CONTINUE 

IFdRUN .NE. 4) GOTO 110 

WRITE(IOU,9002) ILK, M,IBOT,ITOP,JF,XO,YO,XS,YS,X,Y,SIGXNK, SIGYNK, 
1 A1 ,A2,PDEP, LAMBDA, SPEEDN(JF) ,TIM1 ,Q(M) , PDEPMX, PDEPPH - 
110 CONTINUE 

SUMSY = SUMSY + AVGSY 
AVGSY = AVCSY/NSOURC 
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n o o 


120 IF(NSOURC .EQ. 0) GOTO 170 

I = ISTART + NSOURC - 1 
IF(.NOT.DISCRT) GOTO 140 
IF(ILK .EQ. 3) GOTO .170 

C 

C*** SUM DEPOSITION OVER MET LAYERS FOR DISCRETE RECEPTOR. 

C 

PDEPPH =0.0 
PDEPMX =0.0 
DO 130 J = ISTART, I 
PDEPPH = DI(J) + PDEPPH 
130 PDEPMX = CI(J) + PDEPMX 
ISTART = ISTART + NSOURC 
C 

C*** SAVE RESULTS IN COMMON BLOCK EXTRA FOR DISCRETE RECEPTOR. 

LOCATION 1 & 2 = PH WASHOUT DEPOSITION, 

3 & 4 = AL203 WASHOUT DEPOSITION. 

BUFDIS(ILK) = PDEPPH*QPDEPH*VPAR(13) 

BUFDIS(ILK+2) = PDEPMX*1000. 0*VPAR(16) 

GOTO 170 
140 CONTINUE 
C 

c*** COMPUTE MAXIMUM DEPOSITION ON GROUND. CALL SUBROUTINE PDEPR. 
C 

IF(ILK .GT. 2) GOTO 150 

CALL PDEPR(CI ,DI ,YPI , SIGYI , ISTART, I .PDEPMX, PDEPPH,YMMX,YMPH) 
ILKMX = ILK 
ILKPH = ILK 

ISTART = ISTART + NSOURC 
GOTO 160 

150 CALL MAX2L (Cl, DI.YPI, SIGYI, DARC, INDEX, PDEPMX, PDEPPH, 

1 YMMX.YMPH, ILKMX, ILKPH) 

160 CONTINUE 
C 

C*** SAVE RESULTS IN COMMON BLOCK EXTRA FOR MAXIMUM CENTERLINE 
C*** CALCULATIONS. 

C 

II = NILK + 3 

RANGE (IXS.NILK) = SQRT(XO*XO+YMPH*YMPH) 

RANGE (IXS, II) = SQRT(XO*XO+YMMX*YMMX) 

C RADI CONVERTS RADIANS TO DEGREES. ' 

A1 - ATAN2(YMPH,XOP)*RADI 
A2 = A1 + DIRN(NLAYS+ILKPH) + 180.0 
IF(A2 .GT. 360.0) A2 = A2 - 360.0 
IF(A2 .LE. 0.0) A2 = A2 + 360.0 
BEARNG( IXS, NILK) = A2 

IF(YMPH .NE. YMMX) A1 = ATAN2 (YMMX,XOP)*RADI 
A2 - A1 + DIRN(NLAYS+ILKMX) + 180.0 
BEARNG(IXS,I1) = AMOD(A2 , 360. 0) 

SIGYBR(IXS,NILK) = AVGSY 
SIGYBRdXS.Il) » AVGSY 
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VALUES (IXS.NILK) = PDEPPH*QPDEPH*VPAR(13) S4502580 

VALUESaxS.Il) = PDEPMX*1000.0*VPAR(16) S4502590 

170 IFdRUN .EQ. 4) WRITE(IOU,9004) ILK.ILKMX.ILKPH.ISTART.NSOURC, S4502600 
1 PDEPMX,PDEPPH,YMMX,YMPH,AVGSY S4502610 

C S4502620 

r*** S4502630 

^ S4502640 

RETURN S4502650 

Q S4502660 

CF** FORMAT STATEMENTS. S4502670 

CF S4502680 

9001 FORMAT ( 6 2H0*** REEDM WARNING 023, PRECIPITATION DEPOSITION CALCULS4502690 

ITED AT/8H RANGE =,F10.3,11H, AZIMUTH =,F10.3,12H, MET. LAYER, 13/ S4502700 

222H MAY BE OVER ESTIMATED) S4502710 

9002 FORMAT(20H ILK,M,IB0T,IT0P, JF=,5I6/17H XO,YO,XS,YS,X,Y=,6E12.6/ S4502720 

1 33H SIGXNK,SIGYNK,A1,A2,PDEP,LAMBDA=,6E12,6/ S4502730 

2 29H SPEEDN,TIM1,Q,PDEPMX,PDEPPH=,5E12.6) S4502740 

9003 F0RMAT(/34H DIAGNOSTICS FOR DOWNWIND LOCATION, 16, 2F10. 2) S4502750 

9004 F0RMAT(31H ILK,ILKMX,ILKPH,ISTART,NS0URC=,5I6/ S4502760 

1 31H PDEPMX,PDEPPH,YMMX,YMPH,AVGSY=,5E13.6) S4502770 

S4502780 
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SUBROUTINE PDEPR (Cl , DI , YPI , SIGYI , ISTART .NSOURC , RCHI , RDHI , 
1 RYC.RYD) 

. , UPDATE: 8213 SOURCE: 03 SEP 81 LOCATION: KSC 


C THIS SUBROUTINE CALCULATES THE MAXIMUM CENTER LINE 

C WASHOUT DEPOSITION. 

C 

c 

DIMENSION CI(1) ,DI(1) ,SIGYI(1) ,YPI(1) 

IF (NSOURC. EQ. 1) GO TO 20 
DO 10 I = ISTART, NSOURC- 1 
DO 10 J=I+1, NSOURC 
IF(YPI(I).GT.YPI(J)) GO TO 10 
TMP1=YPI(I) 

YPI(I)=YPI(J) 

YPI(J)=TMP1 

TMP1=SIGYI(I) 

SIGYI(I)=SIGYI(J) 

SIGYI (J)=TMP1 
TMP1=CI(I) 

CI(I)=CI(J) 

CI(J)=TMP1 

TMP1=DI(I) 

DI(I)=DI(J) 

DI(J)=TMP1 
10 CONTINUE 
20 CONTINUE 
ISTR= ISTART 
RCHI=0.0 
RDHI=0.0 
RY=0.0 

C CALCULATE THE NUMBER OF SOURCES IN A GROUP 

30 SMIN=SIGYI(ISTR) 

I=ISTR 

40 IFd.GT. NSOURC) GO TO 150 
IFd.EQ. NSOURC) GO TO 50 
J=I+1 

TMP1=YPI(I)-YPI(J) 

TMP2=1. 18* (SIGYI (I)+SIGYI(J)) 

IF(TMP1.GT.TMP2) GO TO 50 
1 = 1+1 
GO TO 40 
50 CONTINUE 

SMIN=SIGYI.(ISTR) 

IF(ISTR.EQ. NSOURC) GO TO 70 
IF(ISTR.EQ. I) GO TO 70 
DO 60 M=ISTR+1,I 
60 SMIN=AMIN1 (SHIN, SIGYI (M)) 

70 YINC=.08*SMIN 
YY=YPI(ISTR) 
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80 YCHI=0.0 
YDHI=0.0 

if(yy.lt.ypKi)) go to 130 
DO 90 M=ISTART,NSOURC 
EX= (YY-YPI (M) ) /SIGYI (M) 

EX = TEXP(EX) 

YDHI=YDHI+DI (M) *EX 
YCHI=YCHI+CI(M)*EX 
90 CONTINUE 

100 IF(YCHI.LT.RCHI) GO TO 110 
RCHI=YCHI 
RYC = YY 

110 IF(YDHI .LT. RDHI) GOTO 120 
RDHI = YDHI 
RYD = YY 
120 YY=YY-YINC 
GO TO 80 
130 CONTINUE 
140 ISTR=I+1 
GO TO 30 

150 IF(RCHI.LE.O.O) RYC = 0.0 
IF (RDHI .LE. 0.0) RYD = 0.0 
RETURN 
END 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c- 

c 


SOURCE: 03 SEP 81 LOCATION: KSC 

THIS SUBROUTINE FINDS THE MAXIMUM DEPOSITION VALUE THAT OrCT’T?q 
OVER TOO MAJOR BOUNDARY LAYERS. FOR A GIVEN oSlNrSlS^ScE 
THIS ROUTINE INCREMENTS ALONG THE YEAR AXES OP BOTH BOimnARV 
CENTERLINES AND SAVES THE MAXIMUM muif FOuS SiS S^TINE 

assumes that ail year VALUES HAVE BEEN ORDERED IN DE^Sr 

™ ™ tJ^YErCESERLINf A? ?Aru 

incremental point on the year axes, year VALUK cai.™. 

ROM EACH SOURCE CLOUD ON THE YEAR AXES TO THE POINT. 


c*** 

c 


c 

c*** 

c 


c 

c** 

c 


C 

c* 

C 


DIMENSION Cl (1) ,DI(1) .SIGYId) .YPI(l) ,INDEX(1) 

DATA RAD/. 01745329/ 

INITIALIZE. 

DARCY = DARC 
RCHI = 0.0 
RDHI =0.0 

RAD CONVERTS FROM DEGREES TO RADIANS 
DTHETR = DTHET*RAD 

BEGIN LOOP OVER MAJOR BOUNDARY LAYERS. 

DO 140 ILK = 1,2 
GET BOUNDARY INDICES. 

IF(ILK .EQ. 2) GOTO 10 
ISTILK =1 
lENILK = INDEX (1) 

ISTOLK = lENILK + 1 
lENOLK = INDEX (2) 

GOTO 20 

10 ISTOLK = ISTILK 
lENOLK = lENILK 
ISTILK = INDEX(l) + 1 
lENILK = INDEX (2) 

DARCY = -DARCY 

BEGIN LOOP OVER INTERVAL WITHIN WHICH TO INCREMENT. 
ISTR = ISTILK 

IFdSTR .GT. lENILK) GOTO 140 
COMPUTE NUMBER OF SOURCES IN THIS INTERVAL. 

I = ISTR 


20 

30 
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40 IF(I .EQ. lENILK) GOTO 50 
II = I + 1 

A1 - YPI(I) - YPI(Il) 

A2 - (SIGYI(I) + SIGYI(I1))*1.18 
IF(A1 .GT. A2) GOTO 50 
I » I + 1 
GOTO 40 
50 lEND - I 

C* COMPUTE INCREMENTAL DISTANCE (DYTLK) & INITIALIZE STARTING 

C* POINT (YILK). 


C 

SMIN - 1.E30 

DO 60 I - l.IEND 

SMIN » AMINKSMIN.SIGYKD) 

60 CONTINUE 

DYILK - .08* SMIN 
YILK - YPI(ISTR) 

C* COMPUTE VALUES FOR THIS INCREMENTAL POINT 4 SAVE MAXIMUMS. 


C 


C 


C 


C 


70 YCHI - 0.0 
YDHI - 0.0 

IFdSTILK .GT. lENILK) GOTO 90 
SUM ALONG YEAR AXIS OF ILK CENTERLINE. 
DO 80 M = ISTILK.IENILK 
A1 - (YILK-YPI(M))/SIGYI(M) 


' A1 = TEXP(Al) 

YCHI * YCHI + CI(M)*A1 
YDHI “ YDHI + DI(M)*A1 
80 CONTINUE 

90 IFdSTOLK .GT. lENOLK) GOTO 110 
SUM ALONG YEAR AXIS OF OTHER(OLK) 
DO 100 M - ISTOLK.IENOLK 
A1 = (YILK+DARCY-YPI(M))/SIGYI(M) 


CENTERLINE. 


A1 - TEXP(Al) 

YCHI - YCHI +CI(M)*A1 
YDHI - YDHI + Dl(M)*Al 
100 CONTINUE 

SAVE MAXIMUMS. 

110 IF(YCHI .LT. RCHI) GOTO 120 
RCHI - YCHI 
YMCL - YILK 
ILKC - ILK 

120 IF (YDHI .LT. RDHI) GOTO 130 
RDHI » YDHI 
YMDL = YILK 
ILKD “ ILK 
130 CONTINUE 


C 

C* DECREMENT TO NEXT POINT. 


C 
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YILK »■ YILK - DYILK 

IF(YILK .GT. YPI(IEND)) GOTO 70 
C 

C* GO GET NEXT INTERVAL. 

ISTR =» lEND + 1 
GOTO 30 
C 

C** END OF MAJOR BOUNDARY LOOP. EITHER GET OTHER CENTERLINE OR DONE. 
140 CONTINUE 

IF(RCHI .LE. 0.0) YMCL =0.0 
IF(RDHI .LE. 0.0) YMDL = 0.0 
C 

c 

c 

RETURN 

END 
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REEDM SOURCE MODULE &RGDPM 



FTN4 

PROGRAM RGDPM(5) 


UPDATE 


8213 ■ SOURCE 


02 APR 82 LOCATION 


KSC 


ORGANIZATION: H. E. CRAMER CO. , INC. 

WORK FOR: DR. J. B. STEPHENS (ES84) 


PROGRAM CODE: RGDPM 


GEOmro-LEVEL DEPOSITION TO GMVITA- 
TIONAL SETTLING FOR A SOURCE THAT EXTENDS VERTICALLY THROUGH AN 

mm Sdaey eayer/ the al203 species is the only one to 

HAVE GRAVITATIONAL DEPOSITION. CALCULATIONS ARE MADE EVERY 
KILOMETER DOWNWIND FROM THE LAUNCH SITE AND. UPON REQUEST. 
CALCULATIONS MAY ALSO BE MADE AT USER-DEFINED DISCRETE 
LOCATIONS. THIS PROGRAM CONTROLS THE PRINT OUTPUT AND PLOT 

OPTIONS. 
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AREA 


CC 

c**** begin common 

04/02/82 

-MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI .G.CP.MAXLEV.GAMMAI.GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE. GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN. MOD EL. IVHICL. NORMAL. TPROP , 

I SHAPE , GAMMAX . G AMMAY . GAMMAZ , ALPHA . BETA . 

XRY . XRZ , XLRY . TIMAV . ISIG . ICALC . CALHT , 

IPLACE . IPRINT , SIGMAR , SIGMER . LSITE . BOTLAY . 

ZRK .DECAY , GOOD , NCI SO . NDISO . NTISO . FILE (3) 

. RAINRT , LAMBDA . TIMl , DURAT . NVS . IVERSN . LOCATN ( 2 ) 
!iPLLNT(4) .GAMMAP(30) .HM(2) .CISO(IO) .DISO(IO) . 

TISO(IO) .TITLE(14) ,SIGPP(29) .SIGLL(29) .VS(20) . 

FS(20) ,MDLNAM(12) .DBAR(20) 

COUNTERS. FLAGS. GENERAL AND INDEX VARIABLES 

LOGICAL I SNDFO , CRT , MAXDEP . BATCH . GASSET . GRVSET , 

MOD EL4 .MODELS .MOD EL6 

’integer RUNNUM.RT.CL.CS 

COMMON /CTRFL/ IFLG.RUNNUM.NUM.NLAYS.NBK.QC.QT.HEAT.ZM.H, 

CO.IMON /LlKtL/ j^pp^;^^^^3yj^j35,^^^RL.IBOT.ITOP.SIGXNK.SIGYNK. 

* SIGZ,ISNDF0.CRT.LAYT0P(3) .itdu.keep 
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, MIXING, MAXDEP,LAYB0T(3) 

, ALTSV , BATCH . CL ( 1 4 ) . CS ( 1 0) , GASSET , lAGAIN , 
ICHAR(12) ,IDXCL,IDXCS, TERROR (5) ,IFRMT(80) , 

MINUSl ,MINUS9,MINS1,MINS9, 

MODEL4 , MODELS , M0DEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY 
RT(24) .TPROPC.IDXRT 

CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS 
INTEGER ALTSET,0FF.,BLNKNG,INV,ULINE,INVNDR, ^^'^^ERS. 

TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP 
CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,0FF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) 
INVNDR(2) ,ULINE(2) , 
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PT ’ CURSUP , CURSDN , CURLFT , CLRDSP .S4800620 
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CLRLNE , INSLNE , DEL INE , 

IESCAJ(3),NULL,IBLNK, 

• »ICU,IYSJ,IYESJ,INJ,IN0J,NAMEP(3) 

C VEHICLE PARAMETERS ’ 

COMMON /VCLPR/ VPAR(17) 

c time parameters • 

COMMON /TIME/ JTIME, JDAY. JYEAR.ISTIME.ISDAY.ISYEAR.LTIME. 

• LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) 

~ ~ “SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) 

„ • RH(30),PTEMP(30),SIGEP(30),SIGAP(30) 

c LAYER PARAMETERS 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , 

• SXGYO(29) 

C CALCULATED BOUND RY DATA (FOR NEW LAYERS) 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) 

C CALCULATED NEW LAYER PARAMETERS c/annian 

^COMMON /NLYER/ ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) .S4800800 

C CONVERSION FACTORS 

^ COMMON /CNVRT/ QC0NV(4) .QPDEPH S4800830 

C***.***«*cOmON BUFFER ARRAY FOR COMMON MODIFICATION«*.«a***..**»**.s48otL‘S 

COMMON /EXTRA/ NCOM(l). NTOTAL(l), PLUS(900) S48008fi0 

C READ/WRITE BUFFER S4800860 

Q ^ R R A Y = 2077 + 1 S4800870 

S4800900 
S4800910 
S4800920 
S4800930 
S4800940 
S4800950 
****54800960 
S4800970 
S4800980 
S4800990 
S4801000 
S4801010 


C 

c**** 

Cc 


EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,1PAR(1)),(I0U,IPAR(2)),(IPU1,IPAR(3)) 
, (IPU2 , IPAR(4) ) , (IPU3 . IPAR(5) ) 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) 

END OF COMMON AREA 


INTEGER UNITS (3, 2) 

DIMENS ION ZTOP ( 2 ) , MILK (2), GDHOLD (4,3), CDAMXS ( 1 ) 

DIMENSION RANGE(30, 1) ,BEARNG(30, 1) ,SIGYBR(30, 1) ,VALUES(30, 1) , 
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c 

c 

c 


c 

c 


1 PEi\KS(2, 1) ,PHIS(50) ,UBARNK(50) ,SIGAPK(50) ,SIGEPK(50) ,IER(2) 
NOTE: THESE DIMENSIONS (10) LIMIT THE MAXIMUM NUMBER OF 

SETTLING CATS TO 10 (SEE MAXNVS IN READM) . OTHERWISE 
THE MAXIMUM COULD BE 20 IF MACHINE SPACE ALLOWED. 
DIMENSION GDEPNM( 10 . 50) , GDEPPl ( 1 0) ,GDEPP2 (10,30) .DBARI3 ( 10) 

1 ,GDPP22(10,3,60) 

EQUIVALENCE (PLUS, RANGE) , (PLUS(181) .BEARNG) , 

1 (PLUS(361) ,SIGYBR) , (PLUSO^l) .CDAMXS) , (PLUS(5A7) , VALUES) , 

2 (PLUS (7 27), PEAKS), (ERR.IER), (GDEPP2 ,GDPP22) 

DATA MILK /5,4/ 

DATA UNITS /2HMG, 2HRA, 2HM. , 2H P,2HAR,2HT./ 

DATA ISXS,NXS,INCXS /2,30,1/ 

DATA JVERSN/8213/ 

IF (IVERSN .NE. JVERSN) CALL LOADS (-1 ,0,0, 0,0, BATCH) 
INITIALIZE. 


C*** 

c 

c 

C! ! ! ! H.E.C COPY ONLY. 

IF (BATCH) GO TO 30 

10 WRITE (ICU.9017) INVNDR, INV,OFF,ULINE,OFF 
READ (IIU,9018) IFRMTl 

IF (IFRMTl. EQ.INJ. OR. IFRMTl. EQ.INOJ) GO TO 220 

IF (IFRMTl. EQ.IBLNK. OR. IFRMTl. EQ.IYSJ.OR.IFRMTl.EQ.IYESJ) GO 

WRITE (ICU,9001) INV,OFF,0,0 
GO TO 10 

20 WRITE (ICU,9014) CURSUP , CLRLNE 
30 CONTINUE 


C! ! ! ! 
C 


JER = 0 
• DO 40 I 
40 PLUS (I) 
DO 50 I 
50 QCONV(I) 


C* 

C* 

C 


1,900 
0.0 
1,4 

= 1.0 

IF(LAYTOP(2) .EQ. 0) GOTO 60 
NLK = 2 
GOTO 70 
60 NLK = 1 
70 CONTINUE 

IBOT = LAYBOT(l) 

ITOP = LAYTOP(l) 

ZTOP(l) = ALT(ITOP+l) 

NILK = 6 - NLK 
ITOP = LAYTOP(2) 

ZTOP(2) = ALT(ITOP+l) 

PARTICLES CONVERSION. DENSITY OF AL203 PARTICLE USED HERE 
G/M**3 (ACTUAL DENSITY = 3.42E6 G/M**3) 

1.9098593E-6 = 6/ (PI*1 . 00E6) 


S4801020 
S4801030 
S4801040 
S4801050 
S4801060 
S4801070 
S4801080 
S4801090 
S4801100 
S4801110 
S4801120 
S4801130 
S4801140 
S4801150 
S4801160 
S4801170 
S4801180 
S4801190 
S4801200 
S4801210 
S4801220 
S4801230 
S4801240 
S4801250 
S4801260 
S4801270 
TO 20S4801280 
S4801290 
S4801300 
S4801310 
S4801320 
S4801330 
S4801340 
S4801350 
S4801360 
S4801370 
S4801380 
S4801390 
S4801400 
S4801410 
S4801420 
S4801430 
S4801440 
S4801450 
S4801460 
S4801470 
S4801480 
S4801490 
S4801500 
= 1E6 S4801510 

S4801520 
S4801530 
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DO 80 I = 1,NVS 

80 DBARI3(I) = 1. 9098593E-6/(1.0E-6*DBAR(I))**3 
C 

IF(IRUN .EQ. 4) WRITE(IOU,9007) 

CALL SHEAR ( UBARNK , PHI S , S IGAPK , S IGEPK , 0) 

C 

C CHECK SEGMENT ENTRY POINT. 

C 

c 

c 

c 

IF(IRUN .NE. 4) GOTO 140 
90 WRITE(ICU,9015) 

CALL IFNBR(IFRMT,20,IER,IIU) 

IF (lER .EQ. 0) GO TO 110 
100 WRITE (ICU,9001) INV.0FF,0,0 
IF (BATCH) GO TO 230 
GO TO 90 

110 CALL CODE (80) 

READ (IFRMT,*) ISXS,NXS,INCXS 
IF (ISXS .NE. MINSl) GO TO 120 
JER = JER+1 

IF (JER .GT. 1) GO TO 230 
WRITE (ICU,9016) 

GO TO 90 
120 JER = 0 

IF (ISXS .EQ. MINS9) GO TO 240 

IF (ISXS ,LE. NXS. AND. INCXS .LE. NXS) GO TO 130 

GO TO 100 

130 WRITE(ICU,9008) lESCAJ 
140 CONTINUE 
LINE = 100 

BEGIN LOOP OVER RANGES. 

DO 170 IXS = ISXS, NXS, INCXS 
XO = (IXS-1)*1000.0 
YO = DIRN(NLAYS+NLK)+ 180.0 
IF (YO .GT. 360.0) YO = YO-360.0 

IF(. NOT. BATCH) WRITE(ICU,9012) CURSUP,MDLNAM,INV,XO,OFF 

CALL GRDEP TO COMPUTE GRAVITATIONAL DEPOSITION. 

CALL GRDEP(XO,YO, IXS, .FALSE. ,NLK,GDHOLD, PH IS, UBARNK, 

1 GDEPNM,GDEPP1,GDEPP2(1,IXS),DBARI3,SIGAPK,SIGEPK) 

FIND MAXIMUM VALUES OVER ALL MAJOR BOUNDARY LAYERS. 

DO 150 ILK = 1,5 

IF(CDAMXSdLK) .GT. VALUES (IXS, ILK)) GOTO 150 
CDAMXS(ILK) = VALUES (IXS, ILK) 

PEAKS (1, ILK) = RANGE (IXS, ILK) 


C 

c*** 

c 


c 

c** 

c 


c 

c** 

c 


S4801540 

S4801550 

S4801560 

S4801570 

S4801580 

S4801590 

S4801600 

S4801610 

S4801620 

S4801630 

S4801640 

S4801650 

S4801660 

S4801670 

S4801680 

S4801690 

S4801700 

S4801710 

S4801720 

S4801730 

S4801740 

S4801750 

S4801760 

S4801770 

S4801780 

S4801790 

S4801800 

S4801810 

S4801820 

S4801830 

S4801840 

S4801850 

S4801860 

S4801870 

S4801880 

S4801890 

S4801900 

S4801910 

S4801920 

S4801930 

S4801940 

S4801950 

S4801960 

S4801970 

S4801980 

S4801990 

S4802000 

S4802010 

S4802020 

S4802030 

S4802040 

S4802050 
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PEAKS (2, ILK) = BEARNG(IXS,ILK) 

150 CONTINUE 
C 

c** FOR RESEARCH MODE, PRINT PARTICLE VALUES FOR ALL 
C** SETTLING CATEGORIES OF THE FIRST BOUNDARY LAYER. 

C 

IF(IRUN .LT, 3) GOTO 170 
IF (LINE .LT. 57) GOTO 160 
LINE = 2A 

WRITE ( lOU ,9002) IVERSN , LOCATN , MDLNAM 
17RITE(IOU,9003) 

WRITE(IOU,9004) TITLE, ZTOP(l) ,ISTIME,LSDT,ISDAY,ISMON,ISYEAR, 
1 LTIME , LSDT , LDAY , LMON , LYEAR , JTIME , LSDT , JDAY , JMON , JYEAR 
WRITE(IOU,9009) 

160 A1 = VALUES(IXS,NLK+3) 

A2 = VALUES UXS,NLK) 

IF(A1 .LT. 0.0005 .AND. A2 .LT. 0.05) GOTO 170 
WRITE (lOU, 90 10) RANGE (IXS,NLK) ,BEARNG(IXS,NLK) ,A1,A2, 

1 (N,GDEPP1(N) ,N=1,NVS) 

LINE = LINE + NVS/4 +1 
170 CONTINUE 

IF (.NOT. BATCH) WRITE (ICU, 9013) CURSUP , CLRDSP , BLNKNG , OFF 
C 

c*** BEGIN OUTPUT — LOOP OVER MAJOR BOUNDARY LAYERS. 

C 

DO 210 ILK = 1,NLK 
II = ILK + 3 

IF(NLK .EQ. 2) II = MILK (ILK) 

IF(IRUN .GT. 2 .AND. ILK .EQ. 1) GOTO 210 


C 

C** 

c 


BEGIN LOOP OVER RANGES. 


LINE = 100 

DO 200 IXS = ISXS,NXS,INCXS 
IF(LINE .LT. 57) GOTO 180 
C* PRINT HEADING. 

LINE = 24 

WRITE(IOU,9002) IVERSN, LOCATN, MDLNAM 
WRITE (lOU, 9 00 3) 

WRITE(IOU,9004) TITLE, ZTOP (ILK) ,ISTIME,LSDT,ISDAY,ISMON,ISYEAR, 

1 LTIME,LSDT,LDAY,LM0N,LYEAR, JTIME, LSDT, JDAY, JMON, JYEAR 

IFdRUN .GT. 2) WRITE(IOU,9009) 

IF(IRUN .LT. 3) WRITE(IOU,9011) 

C* PRINT RESULTS. 

180 A1 = VALUES (IXS, II) 

A2 = VALUES (IXS, I 1-3) 

IF (IRUN .LT. 3.AND.A1 .LT. .0005) GO TO 200 
IF(A1 .LT. 0.0005 .AND. A2 .LT. 0.05) GOTO 200 
IF(IRUN .GT. 2) GOTO 190 

WRITE(IOU,9005) RANGE(IXS , II) , BEARNG ( IXS , I 1 ) ,A1,A2 
GOTO 200 

190 WRITE(IOU,9010) RANGE(IXS,I1) ,BEARNG(IXS,I1) ,A1,A2, 


S4802060 

S4802070 

S4802080 

S4802090 

S4802100 

S4802110 

S4802120 

S4802130 

S4802140 

S4802150 

S4802160 

S4802170 

S4802180 

S4802190 

S4802200 

S4802210 

S4802220 

S4802230 

S4802240 

S4802250 

S4802260 

S4802270 

S4802280 

S4802290 

S4802300 

S4802310 

S4802320 

S4802330 

S4802340 

S4802350 

S4802360 

S4802370 

S4802380 

S4802390 

S4802400 

S4802410 

S4802420 

S4802430 

S4802440 

S4802450 

S4802460 

S4802470 

S4802480 

S4802490 

S4802500 

S4802510 

S4802520 

S4802530 

S4802540 

S4802550 

S4802560 

S4802570 
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1 (N,GDEPP2(N,IXS),N-1,NVS) 

LINE => LINE + NVS/5 + 1 
200 CONTINUE 
C 

C** PRINT MAXIMUM VALUE FOUND OVER ALL RANGES. 

C 

210 WRITE (lOU, 9006) CDAMXS(Il) ,PEAKS(1,I1) ,PEAKS(2,I1) 
IF(. NOT. BATCH) WRITE (ICU, 9014) CURSUP.CURLFT.CLRDSP 
C UNLOCK PRINTER. 

220 CONTINUE 
C 
C 
C 

NNNEST = 3 
NNNTRY =■ 4 
GO TO 260 
C 

C*** ERROR EXIT. 

C 

230 lERROR(l) « MINSl 
GO TO 250 
240 lERROR(l) =■ 1 
250 NNNEST - 1 
NNNTRY => 3 
260 CONTINUE 
CALL REEDM 


S4802580 

S4802590 

S4802600 

S4802610 

S4802620 

S4802630 

S4802640 

S4802650 

S4802660 

S4802670 

S4802680 

S4802690 

S4802700 

S4802710 

S4802720 

S4802730 

S4802740 

S4802750 

S4802760 

S480I776 

S4802780 

S4802790 

S4802800 

S4802810 

S4802820 

S4802830 

S4802840 

S4802850 


FORMAT STATEMENTS. 


a‘*ouzoou 

S4802870 

S4802880 


9001 FOmi (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2.6H REC. S4802890 


9002 WlATaHl,38(2H**)/lX,8(2H**),44X,8(2H**)/ $4802910 

1 1X,8(2H**),3X,13HREEDM UPDATE, 15, IIH LOCATION ,2A2,8X,8(2H**)/ S4802920 

2 IX, 8(2H**),7X,12A2,6H MODEL, 7X,8(2H**)/ S4802930 

3 1X,8(2H**),44X,8(2H**)/1X,38(2H**)/) S4802940 

9003^F0RMAT(1X,8(2H**) ,7X,31HMAXIMUM CENTERLINE CALCULATIONS, 6X, 8 (2H**) S4802950 

' S4802960 

9004 F0RMAT(/27X,25HF0R AL203 AT GROUND-LEVEL/ 1 5X, 16HD0WNWIND FROM A , S4802970 

1 14A2,7H LAUNCH/4X,56HCALCULATIONS APPLY TO THE LAYER BETIJEEN THE S4802980 
2SURFACE AND .F7.2.7H METERS //9X, 3 IHTHE METEOROLOGICAL DATA IS FROMS4802990 

LAUNCH TIME IS,I10,2A2,I4, 1X,2A2,I4S4803000 
4/15X,20HTIME OF EXECUTION IS,I10,2A2,I4,1X.2A2,I4//) S4803010 

9005 F0RMAT(11X,2F12.3,F14.3,1PE18.5) 548030^0 

9006 F0RMAT(//56X,16HRANGE BEARING/53X,10(2H— )/FT5.3, S4803036 

1 37H IS THE PEAK GRAVITATIONAL DEPOSITION, 2F1 0.3) S4803040 

9007 FORMAT (4 7H1DI AGNOSTICS FOR GRAVITATIONAL DEPOSITION MODEL/) S4803050 

9008 F0RMAT(2A2,A1) 548030^0 

9009 FOR1L\T(30X, 28H- GRAVITATIONAL DEPOSITION -/ S4 803070 

1 7X.50HRANGE BEARING (MILLIGRAMS/ (PARTICLES/, 16X, S4803080 

2 34H- PARTICLES BY SETTLING CATEGORY -/ 54803090 
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3 5X.25H (METERS) (DEGREES) ,2(11H(S0. METER), 5X), oAon^lJn 

90lo^oSax;2Fl2'3!nI"3!lm 

9011iFOK^T(4^,28H- GRAVITATIONAL ^RROSITI^-/ S4803140 

2 15x!25H (METERS) (DEGREES) ,2(11H(SQ. METER) ,5X)/15X,27(2H 

o N \ 

9012 FORMAT (A2, IX. 12A2.30H MODEL IS PROCESSING RANGE AT , 2A2 ,F7 . 1 ,2A2 , S4803170 


1 7H M^7T^7^?c;^ S4803180 

1 7H METERS/ c/ fin'll on 

■ 9013 FORMAT(2A2,10X,2A2.8HPRINTING,2A2) cARn79nn 

9014 FORMAT(3A2) ^ c/Qn99in 

9015 FORMAT(41H DIAGNOSITIC RUN. ENTER ISXS,NXS,INCXS:_) .•nor.-roc/ 

9016 FORMAT (73H *** REEDM WARNING 019, -1 NOT APPLICABLE, PROG. AB0RTSS4803.20 

. IF -I TYPED AGAIN) =4803230 

C ' • * H E C COPY ONLY. S4803250 

9017 FORMAT (57HDO YOU WISH MAXIMUM CENTERLINE GRAVITATIONAL DEPOSITI0NS4803260 

*?(,2A2.1HY,2A2,2HES.2A2,1H..2A2,1HN,2A2,4H0):J S4803270 

9018 FORMAT (A2) S4803290 

G--'- S4803300 

G S4803310 

END 
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REEDM SOURCE MODULE &RGPDM 


FTN4 

PROGRAM RGPDM(5) 
. , UPDATE: 8213 


SOURCE 


02 APR 82 LOCATION 


ORGANIZATION: H. E. CRAMER CO. , INC. 

WORK FOR: DR. J, B. STEPHENS (ES84) 

PROGRAM CODE: RGPDM 

PROGRAM DESCRIPTION: 

THIS PROGRAM CALCULATES GROUND-LEVEL DEPOSITION DUE TO GRAVITA- 
TIONAL SETTLING FOR A SOURCE THAT EXTENDS VERTICALLY THROUGH AN 
ENTIRE BOUNDARY LAYER. THE AL203 SPECIES IS THE ONLY ONE TO 
HAVE GRAVITATIONAL DEPOSITION. CALCULATIONS ARE MADE EVERY 
KILOMETER DOli/NUIND FROM THE LAUNCH SITE AND, UPON REQUEST 
CALCULATIONS MAY ALSO BE MADE AT USER-DEFINED DISCRETE 

LOCATIONS. THIS PROGRAM CONTROLS THE PRINT OUTPUT AND PLOT 
OPTIONS. 


begin common AREA 

04/02/82 

MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL,NORMAL,TPROP, 

I SHAP E , G AMMAN , GAMMAY , GAMMAZ , ALPHA , B ETA , 

XRY , XRZ , XL RY , T IMAV ,ISIG,ICALC, CALHT , 
IPLACE,IPRINT,SIGMAR, SIGNER, LSITE.BOTLAY, 

ZRK , DECAY , GOOD , NCI SO , NDI SO , NTISO , FILE (3 ) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14),SIGPP(29),SIGLL(29),VS(20) . 
FS(20),MDLNAM(12),DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 
LOGICAL I SNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

M0DEL4, MODELS, M0DEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , S IGYNK , 

S IGZ , I SND FO , CRT , LAYTOP (3 ) , ITDU , KEEP 
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, MIXING, MAXDEP,LAYB0T(3) S4900500 

,ALTSV, BATCH, CL(14) ,CS(10) .GASSET, I AGAIN, S4900510 

ICHAR(12) ,IDXCL,IDXCS,IERR0R(5) ,IFRMT(80) , S4900520 

MINUS1,MINUS9,MINS1,MINS9, S4900530 

MODEL 4 , MODEL 5 , MODEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , S4900540 

RT(24) ,TPROPC,IDXRT S4900550 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S4900560 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S4900570 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S4900580 

CLRLNE.INSLNE, DELINE S4900590 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S4900600 

INVNDR(2),ULINE(2), S4900610 

T AB , TAB 2 , S ETT AB , CLRT AB , CURSUP , CURSDN , CURL FT,CLRDSP,S4900620 
CLRLNE.INSLNE, DELINE, S4 900630 

IESCAJ(3) .NULL.IBLNK, S4900640 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S4900650 

C VEHICLE PARAMETERS S4900660 

COMMON /VCLPR/ VPAR(17) S4900670 

C TIME PARAMETERS S4 900680 

COMMON /TIME/ JTIME, JDAY, JYEAR.ISTIME.ISDAY.ISYEAR.LTIME, S4900690 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S4900700 

C SOUND ING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S4900710 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S4900720 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S4900730 

C LAYER PARAMETERS S4 9007 40 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) , SIGXO(29) , S4900750 

SIGYO(29) S4900760 

C CALCULATED FOUNDRY DATA (FOR NEW LAYERS) S4900770 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S4900780 

C CALCULATED NEW LAYER PARAMETERS S4900790 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) , SIGEPN(32) , S4900800 
SPEEDN(32) S4900810 

C CONVERSION FACTORS S4900820 

COMMON /CNVRT/ QCONV(4) .QPDEPH S4900830 

C S4900840 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S4900850 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S4900860 

C READ/WRITE BUFFER S4900870 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S4900880 

*********** A*;^****:*?*************:*:******************** ***:*?** ******* S49QQggO 


C 

c- 


C 

c**** 


EQUIVALENCE STATEMENTS 

EQUIVALENCE(IIU,IPAR(1)) , (lOU, IPAR(2) ) , (IPUl , IPAR(3) ) 
, (IPU2 , IPAR(4) ) , (IPU3 , IPAR(5) ) 

EQUIVALENCE (MAXDEP .GRVSET) , (IFRMT(l) .IFRMTl) 

END OF COMMON AREA 


S4900900 

S4900910 

S4900920 

S4900930 

S4900940 

S4900950 

****34900960 


Cc 

INTEGER UNITS (3, 2) 

LOGICAL IBATCH 
C 

DIMENSION DISBUF(14,1) ,ZTOP(2) ,GDHOLD(4,3) , 


S4900970 

S4900980 

S4900990 

S4901000 

S4901010 
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1 PHIS(50) ,UBARNK(50) ,SIGAPK(50) ,SIGEPK(50) ,IER(2) 

NOTE: THESE DIMENSIONS (10) LIMIT THE MAXIMUM NUMBER OF 

SETTLING CATS TO 10 (SEE MAXNVS IN READM) . OTHERWISE, 
THE MAXIMUM COULD BE 20 IF MACHINE SPACE ALLOWED. 
DIMENSION GDEPNM(10,50) ,GDEPP1(10) ,GDEPP2(10,30) ,DBARI3(10) 

1 ,GDPP22(10,3,60) ,IDDISR(10,60) 

EQUIVALENCE (PLUS ,DISBUF) , 

2 (ERR.IER), (GDEPP2,GDPP22) 

DATA UNITS /2HMG, 2HRA, 2HM, , 2H P,2HAR,2HT./ 

DATA NXS /30/ 

DATA IBATCH /.FALSE./ 

DATA JVERSN/8213/ 


IF (IVERSN .NE. JVERSN) CALL LOADS(-l ,0,0, 0,0, BATCH) 

C*** INITIALIZE. 

C 

JER = 0 
DO 10 1=1,900 
10 PLUS(I) =0.0 
DO 20 1=1,4 
20 QCONV(I) =1.0 

IF(LAYTOP(2) .EQ. 0) GOTO 30 
NLK = 2 
GOTO 40 
30 NLK = 1 
40 CONTINUE 

IBOT = LAYBOT(l) 

ITOP = LAYTOP(l) 

ZTOP(l) = ALTUTOP+1) 

NILK = 6 - NLK 
ITOP = LAYTOP(2) 

ZT0P(2) = ALTUTOP+1) 

C* PARTICLES CONVERSION. DENSITY OF AL203 PARTICLE USED HERE = 1E6 
C* G/M**3 (ACTUAL DENSITY = 3.42E6 G/M**3) 

C 1.9098593E-6 = 6/ (PI*1 . 00E6) 

DO 50 I = 1,NVS 

50 DBARI3(I) = 1.9098593E-6/(1.0E-6*DBAR(I))**3 
C 

IF(IRUN .EQ. 4) WRITE(IOU,9007) 

CALL SHEAR(UBARNK,PHIS,SIGAPK,SIGEPK,0) 

C 

C*A* CHECK FOR DISCRETE RECEPTOR CALCULATIONS. 

C 

60 lER = 0 

IF (.NOT. BATCH) GOTO 70 
READ ( I lU, 9005) IDMY 
GOTO 80 

70 WRITE(ICU,9015) INVNDR,INV,OFF, (ULINE,OFF,I=l ,2) 

CALL IFNBR(IFRMT,14,IER,IIU) 


S4901020 

S4901030 

S4901040 

S4901050 

S4901060 

S4901070 

S4901080 

S4901090 

S4901100 

S4901110 

S4901120 

S4901130 

S4901140 

S4901150 

S4901160 

S4901170 

S4901180 

S4901190 

S4901200 

S4901210 

S4901220 

S4901230 

S4901240 

S4901250 

S4901260 

S4901270 

S4901280 

S4901290 

S4901300 

S4901310 

S4901320 

S4901330 

S4901340 

S4901350 

S4901360 

S4901370 

S4901380 

S4901390 

S4901400 

S4901410 

S4901420 

S4901430 

S4901440 

S4901450 

S4901460 

S4901470 

S4901480 

S4901490 

S4901500 

S4901510 

S4901520 

S4901530 
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IDMY = IFRMT(l) 

IF(IDMY.EQ.MINUS9) GOTO 420 
IF ( IDMY. NE. MINUS 1) GO TO 80 
JER = JER+1 

IF (JER .GT. 1) GO TO 410 
WRITE (ICU.9022) 

GO TO 70 
80 JER = 0 

IF(IDMY .EQ. INJ .OR. IDMY .EQ. INOJ) GOTO 430 
IF(IDMY.EQ.IBLNK.OR.IDMY.EQ.IYSJ.OR.IDMY.EQ.IYESJ) GOTO 100 
IF (lER .EQ. 0) GO TO 90 
WRITE (ICU,9001) INV, OFF, 23,0 
IF (BATCH) GO TO 410 
GO TO 70 

90 IBATCH = .TRUE. 

IIUTMP = IIU 
CALL CODE (2) 

READdDMY,*) IIU 
WRITE (ICU, 9008) lESCAJ 


C*** BEGIN DISCRETE RECEPTOR CALCULATIONS. 

C 

100 GDMAX - 0.0 
YTMAX = 0.0 
MIXS =1 
NXS = 0 
■ LINED = 100 
LINEP =■ 100 

C QUERY RECEPTOR LOCATION. 

110 CONTINUE 

DO 120 J = 1,10 
120 IFRMT(15+J) = IBLNK 

IF (.NOT. BATCH .AND. .NOT. IBATCH) GOTO 
IF(NXS .GT. 59) GOTO 320 
ERR - EXEC(l,IIU,IFRMT,-80) 

IF(IER(2) .LE. 0) GOTO 320 
CALL IFNBR(IFRMT,-26,IER,IIU) 

IF (lER .EQ. 0) GO TO 130 
WRITE (ICU, 9001) INV, OFF, 23,1 
GO TO 110 
130 CALL CODE (30) 

READ(IFRMT,*) XT,YT 
IF(XT .LT. 0.0) GOTO 320 
GOTO 200 

140 WR1TE(ICU,9009) CURSUP ,CLRDSP 
150 CALL IFNBR(IFRMT,26,IER,IIU) 

IF (lER .EQ. 0) GO TO 170 
160 TOITE (ICU, 9001) INV, OFF, 23,1 
WRITE (ICU, 9009) IBLNK, IBLNK 
GO TO 150 
170 CALL CODE (80) 

READ (IFRMT,*) XT,YT 


S4901540 
S4901550 
S4901560 
S4901570 
S4901580 
S4901590 
S4901600 
S4901610 
S4901620 
S4901630 
S4901640 
S4901650 
S4901660 
S4901670 
S4901680 
S4901690 
S4901700 
S4901710 
S4901720 
S4901730 
S4901740 
S4901750 
S4901760 
S4901770 
S4901780 
S4901790 
S4901800 
S4901810 
S4901820 
S4901830 
S4901840 
S4901850 

140 S4901860 

S4901870 

S4901880 

S4901890 

S4901900 

S4901910 

S4901920 

S4901930 

S4901940 

S4901950 

S4901960 

S4901970 

S4901980 

S4901990 

S4902000 

S4902010 

S4902020 

S4902030 

S4902040 

S4902050 
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IF (XT .EQ. MINSl) GO TO 180 
IF (XT .EQ. MINS9) GO TO 420 
IF (XT .GE. 0.0) GO TO 190 
GO TO 160 

180 WRITE(ICU,9008) lESCAJ 
GOTO 60 

190 WRITE(IGU,9010) (GURSUP,GURLFT,GLRDSP,I=1 ,2) 

C 

C** MAKE 3 GALCULATIONS PER DISCRETE RECEPTOR ENTERED. 

C 

200 YTl = YT - 10.0 

IF(YT1 .LE. 0.0) YTl = YTl + 360.0 
NXS = NXS + 1 
DISBUF(1,NXS) = XT 
DISBUF(2,NXS) = YTl 
DO 210 J = 1,10 

210 IDDISR(J,NXS) = IFRMT(15+J) 

DO 250 J = 1,3 
DO 220 1=1,4 
220 GDHOLD(I,J) =0.0 

C* CALL GRDEP TO COMPUTE GRAVITATIONAL DEPOSITION. 

CALL GRDEP(XT, YTl, NXS,. TRUE. ,NLK,GDHOLD(l,J), PHIS, UBARNK, 

1 GDEPNM , GDEPP 1 , GDPP22 ( 1 , J , NXS ) , DBARI3 , SIGAPK , SIGEPK) 

C 

C* FOR RESEARCH MODE, PRINT PARTICLE VALUES FOR ALL SETTLING 
C* CATEGORIES OF THE FIRST BOUNDARY LAYER. 

C 

IF(IRUN .LT. 3) GOTO 240 
IF(LINEP .LT. 53) GOTO 230 
LINEP = 23 

WRITE ( lOU , 900 2 ) I VERSN , LOCATN , MDLNAM 
WRITE(IOU,9006) 

WRITE ( lOU , 9 00 3 ) TITLE , ZTOP ( 1 ) , I STIME , LSDT , I SDAY , I SMON , I SYEAR , 

1 LTIME , LSDT , LDAY , LMON , LYEAR , JTIME , LSDT , JDAY , JMON , JYEAR 
WRITE(IOU,9019) 

230 A1 = GDHOLD(l,J) 

A2 = GDHOLD(3,J) 

IF(A1 .LT. 0.0005 .AND. A2 .LT. 0.05) GOTO 240 
IF(J.NE.2) WRITE(IOU,9020) XT,YT1,A1,A2, (N,GDEPP1 (N) ,N=1 ,NVS) 
IF(J.EQ.2) WRITE(IOU,9016) (IDDISR(N,NXS) ,N=1 , 10) ,XT,YT1 ,A1 ,A2, 
1 (N,GDEPP1(N),N=1,NVS) 

LINEP = LINEP + NVS/4 + 1 
IF(GDMAX .GT. Al) GOTO 240 
GDMAX = Al 
YTMAX = YTl 
MIXS = NXS 
240 YTl = YTl + 10.0 

IF(YT1 .GT. 360.0) YTl = YTl - 360.0 
250 CONTINUE 
C 

C** SAVE RESULTS IN BUFFER. 

C 


S4902060 

S4902070 

S4902080 

S4902090 

S4902100 

S4902110 

S4902120 

S4902130 

S4902140 

S4902150 

S4902160 

S4902170 

S4902180 

S4902190 

S4902200 

S4902210 

S4902220 

S4902230 

S4902240 

S4902250 

S4902260 

S4902270 

S4902280 

S4902290 

S4902300 

S4902310 

S4902320 

S4902330 

S4902340 

S4902350 

S4902360 

S4902370 

S4902380 

S4902390 

S4902400 

S4902410 

S4902420 

S4902430 

S4902440 

S4902450 

S4902460 

S4902470 

S4902480 

S4902490 

S4902500 

S4902510 

S4902520 

S4902530 

S4902540 

S4902550 

S4902560 

S4902570 
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noon 


L = 2 

DO 270 J = 1,3 
DO 260 K = 1,4 

260 DISBUF(L+K,NXS) = GDH0LD(K,J) 

270 L = L + 4 

IF(BATCH) GOTO 110 

** DISPLAY DISCRETE RECEPTOR RESULTS. 

DISPLAY HEADING. 

IF(LINED .LT. 22) GOTO 280 
LINED = 5 

WRITE ( I CU . 9 0 1 1 ) ( ZTOP ( I ) , 1= 1 , NLK) 

WRITE(ICU,9023) 

280 CONTINUE 

LINED = LINED + 5 
C DISPLAY LOCATION AND RESULTS. 

WRITE(ICU,9012) XT,YT, ((UNITS(I,K) ,1=1 ,3) , ((GDHOLD(J+K-l ,1) , 
1 1=1,3) ,J=K,K+1),K=1,2) 

IF(NXS .LT. 60) GOTO 290 
C MAX. NO. OF RECEPTORS HAVE BEEN ENTERED. 

WRITE(ICU,9013) 

GOTO 320 

C QUERY ANOTHER RECEPTOR. 

290 IF(IBATCH) GOTO 110 

WRITE(ICU,9014) INVNDR, INV,OFF,ULINE,OFF 

IDMY = IBLNK 

READ(IIU,9005) IDMY 

IF(IDMY .EQ. MINUS9) GOTO 420 

IFaOMY .NE. MINUS 1) GOTO 300 

WRITE(ICU,9008) lESCAJ 

GOTO 60 , 

300 IF(IDMY.EQ. IBLNK. OR. IDMY. EQ. lYSJ. OR. IDMY. EQ. lYESJ) GO TO 110 
IF (IDMY .EQ. INJ.OR.IDMY .EQ.INOJ) GO TO 310 
WRITE (ICU,9001) INV, OFF, 23,2 
GO TO 290 

C CURSOR UP AND 17RITE BLANK LINE. 

310 WRITE(ICU,9010) CURSUP,CURLFT,CLRDSP 
WRITE(ICU,9005) 

• C** PRINT MAXIMUM FOR LAYER ONE, RESEARCH MODE. 

IF(IRUN .GT. 2) WRITE (lOU, 9004) GDMAX,DISBUF(1 ,MIXS) ,YTMAX 

C 

c** PRINT DISCRETE RECEPTOR RESULTS. 

C 

320 CONTINUE 

IF (.NOT. I BATCH) GOTO 330 
IIU = IIUTMP 
WRITE(ICU,9005) IBLNK 

C* BEGIN LOOP OVER MAJOR BOUNDARY LAYERS. 

330 DO 400 ILK = 1,NLK 

IF(IRUN .GT. 2 .AND. ILK .EQ. 1) GOTO 400 

GDMAX =0.0 


S4902580 

S4902590 

S4902600 

S4902610 

S4902620 

S4902630 

S4902640 

S4902650 

S4902660 

S4902670 

S4902680 

S4902690 

S4902700 

S4902710 

S4902720 

S4902730 

S4902740 

S4902750 

S4902760 

S4902770 

S4902780 

S4902790 

S4902800 

S4902810 

S4902820 

S4902830 

S4902840 

S4902850 

S4902860 

S4902870 

S4902880 

S4902890 

S4902900 

S4902910 

S4902920 

S4902930 

S4902940 

S4902950 

S4902960 

S4902970 

S4902980 

S4902990 

S4903000 

S4903010 

S4903020 

S4903030 

S4903040 

S4903050 

S4903060 

S4903070 

S4903080 

S4903090 
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c* 


YTMAX =0.0 
MIXS = 1 
LINEP = 100 

BEGIN LOOP OVER NUMBER OF DISCRETE RECEPTORS 
DO 390 IXS = l.NXS 
IF(LINEP .LT. 53) GOTO 340 
LINEP =23 
C PRINT HEADING. 

WRITE(IOU,9002) IVERSN.LOCATN.MDLNAM 
raiTE(IOU,9006) 

WRITEdOU, 9003) TITLE, ZTOP (ILK) , ISTIME,LSDT, ISDAY, ISMON, ISYEAR 

1 ltime,lsdt,lday,lmon,lyear,jtime,lsdt,jday,jmon,jyear 

IF(IRUN .GT. 2) WRITEdOU, 9019) 

IFdRUN .LT. 3) WRITEdOU, 9021) 

340 XT = DISBUFd.IXS) 

YTl = DISBUF(2,IXS) 

L = 2 

DO 380 J = 1,3 
C PRINT RESULTS. 

A1 = DISBUF(L+ILK,IXS) 

A2 = DISBUF(L+ILK+2,IXS) 

IF(A1 .LT. 0.0005 .AND. A2 .LT. 0.05) GOTO 370 

IF(A1 .LT. GDMAX) GOTO 350 

GDMAX = A1 

YTMAX = YTl 

MIXS = IXS 

350 IFdRUN .GT. 2) GOTO 360 
LINEP = LINEP + 1 

IF(J.NE.2) WRITEdOU, 9018) XT,YT1,A1,A2 

IF(J.EQ.2) WRITE (lOU, 9017) (IDDISR(N, IXS) ,N=1 , 10) ,XT,YT1 , A1 A2 
GOTO 370 

360 IF(J.NE.2) WRITEdOU, 9020) XT,YT1 , A1 , A2 , (N,GDPP22 (N. J, IXS) , 

^ , N=1,NVS) 

IF(J. EQ. 2) WRITE (lOU, 9016) (IDDISR(N, IXS) ,N=1 , 10) ,XT, YTl ,A1 ,A2 , 

^ (N,GDPP22(N, J.IXS) ,N=1,NVS) 

LINEP = LINEP + NVS/4 +1 
370 YTl = YTl + 10.0 

IF(YT1 .GT. 360.0) YTl = YTl - 360.0 
380 L = L + 4 
390 CONTINUE 

C* PRINT MAXIMUM RESULT FOUND OVER DISCRETE RECEPTORS. 
WRITE(IOU,9004) GDMAX,DISBUF(1 ,MIXS) .YTMAX 
400 CONTINUE 
GOTO 430 
C 

C*** ERROR EXIT. 

C 


410 lERROR(l) = MINSl 
GOTO 430 

420 lERROR(l) = 1 
C 

C*** RETURN TO MAIN PROGRAM. 


S4903100 

S4903110 

S4903120 

S4903130 

S4903140 

S4903150 

S4903160 

S4903170 

S4903180 

S4903190 

S4903200 

S4903210 

S4903220 

S4903230 

S4903240 

S4903250 

S4903260 

S4903270 

S4903280 

S4903290 

S4903300 

S4903310 

S4903320 

S4903330 

S4903340 

S4903350 

S4903360 

S4903370 

S4903380 

S4903390 

S4903400 

S4903410 

S4903420 

S4903430 

S4903440 

S4903450 

S4903460 

S4903470 

S4903480 

S4903490 

S4903500 

S4903510 

S4903520 

S4903530 

S4903540 

S4903550 

S4903560 

S4903570 

S4903580 

S4903590 

S4903600 

S4903610 
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430 CONTINUE 
NNNEST = 1 
NNNTRY = 3 
CALL REEDM 
C 

CF** FORMAT STATEMENTS . 

CF 

9001 FORMAT (2A2.38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2.6H REC. 
*,I2,1H. ,11/) 

9002 F0RMAT(1H1,38(2H**)/1X,8(2H**),44X,8(2H**)/ 


S4903620 

S4903630 

S4903640 

S4903650 

S4903660 

S4903670 

S4903680 

S4903690 

S4903700 

S4903710 

S4903720 


1 IX 8(2H**) ,3X,13HREEDM UPDATE, 15, IIH LOCATION ,2A2,8X,8(2H**) / S4903730 

^ ^ » AAnAOT/. A 


S4903740 

S4903750 

S4903760 


2 1X.8(2H**),7X,12A2,6H MODEL,7X,8(2H**)/ 

3 1X,8(2H**) ,44X,8(2H**)/1X,38(2H**)/) 

9003 FORMAT (/27X, 2 5HF0R AL203 AT GROUND-LEVEL/ 15X, 16HD0WNWIND FROM A 

1 14A2,7H LAUNCH/4X,56HCALCULATI0NS APPLY TO THE LAYER BETWEEN THE S4903770 
2SURFACE AND ,F7.2,6H METERS //9X, 3 IHTHE METEOROLOGICAL DATA IS FROMS4903780 
3 ,I5,2A2.I4,1X,2A2,I4/19X,16H LAUNCH TIME IS,I10,2A2,I4,1X,2A2,I4S4903790 


S4903800 

S4903810 

S4903820 

S4903830 

S4903840 

S4903850 

S4903860 

S4903870 


4/15X,20HTIME OF EXECUTION IS,I10,2A2,I4,1X,2A2,I4//) 

9004 FORMAT (/ /56X, 16HRANGE BEARING/53X, 10 (2H — )/F15.3, 

1 37H IS THE PEAK GRAVITATIONAL DEPOSITION, 2F10. 3) 

9005 FORMAT (A2) 

9006 F0RMAT(1X,8(2H**) ,7X,30HDISCRETE RECEPTOR CALCULATIONS, 7X, 

1 8(2H**)) 

9007 FORMAT (47H1DIAGNOSTICS FOR GRAVITATIONAL DEPOSITION MODEL/) 

9009 FORMAT(2A2,68H ENTER DISCRETE RECEPTOR LOCATION RELATIVE TO LAUNCHS4903880 

1 PAD. A 20 CHAR./52H COMMENT MAY BE ENTERED STARTING UNDER THE ASTS4903890 
2ERISK. , lOX, 1H*/33H RANGE (METERS ), BEARING (DEGREES) ;_) S4903900 

9010 FORMAT(3A2) 

9011 F0RMAT(1X,37(2H**)/23X,34HGRAVITATI0NAL DEPOSITION FOR A1203/ 

1 lOH LAYERS = , 2 (IH* , 7X, 1 IHSURFACE TO ,F7.2,7X)) S4903930 

9012 F0RMAT(/11X,26HDISCRETE RECEPTOR RANGE = ,F7.1,11H, BEARING -,F6. 1S4903940 

1/lX 3A2 IX 2(3H * ,3 (IX, F9 . 3) ) /1X.3A2 , IX, 2 (3H *,1P3E10.3)) S4903950 

9013 FORMT(63H A MAXIMUM OF 60 DISCRETE RECEPTOR LOCATIONS HAVE BEEN ES4903960 

1NTERED./29H THIS SECTION IS TERMINATED ._) S4903970 

9014 FORMAT(58H DO YOU WISH TO ENTER ANOTHER DISCRETE RECEPTOR LOCATIONS4903980 
1 ? ( , 2A2 , IHY , 2A2 , 2HES , 2A2 , IH , , 2A2 , IHN , 2A2 , 4HO) :_) 

9015 FORMAT(46H DO YOU WISH DISCRETE RECEPTOR CALCULATIONS? (,2A2,1HY, S4904000 
1 2A2,2HES,2A2,lH,,2A2,lHN,2A2,2HO,,2A2,3HLU#,2A2,16H OF DATA 


2 : ) 

9016 FORMAT(1X,10A2,1X,2F11.3,F13.3,1PE18.5,2X,3(I5,E13.5)/ 

1 (73X,3(I5,E13.5))) 

9017 FORMATOX,10A2,2F12.3,F14.3,1PE18.5) 

9018 F0RMAT(21X,2F12.3,F14.3,1PE18.5) 

9019 FORMAT(49X,28H- GRAVITATIONAL DEPOSITION -/ 

1 28X,48HRANGE BEARING (MILLIGRAMS/ (PARTICLES/ , 14X, 

2 34H- PARTICLES BY SETTLING CATEGORY -/6X, 10HIDENTIFIER,10X, 

3 34H(METERS) (DEGREES) (SQ. METER) ,5X, 11H(SQ. METER), 4X, 

4 3(12HCAT. DEP. ,6X)/1X,65(2H— )) 

9020 FORMAT(22X,2F11.3,F13, 3, 1PE18.5,2X,3(I5,E13.5)/(73X,3(I5,E13.5))) 

9021 FORMAT (50X,28H- GRAVITATIONAL DEPOSITION -/ 


S4904020 

S4904030 

S4904040 

S4904050 

S4904060 

S4904070 

S4904080 

S4904090 

S4904100 

S4904110 

S4904120 

S4904130 
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1 27X.50HRANGE BEARING (MILLIGRAMS/ (PARTICLES/ /6X, S4904140 

2 10HIDENTIFIER.9X,25H (METERS) (DEGREES) ,2(11H(SQ. METER) . 5XS4904 150 

3)/lX,38(2H )) S4904160 

9022 F0R>1AT (73H *** REEDM WARNING 019, -1 NOT APPLICABLE, PROG. ABORTSS4904170 

* IF -1 TYPED AGAIN) S4904180 

9023 FORMAT(8X,2(33H * -10 DEG. POINT +10 DEG. ) /IX, 37 (2H**) ) S4904190 

S4904200 


228 


n o 


REEDM SOURCE MODULE &RGDPN 


FTN4 

SUBROUTINE GRDEP (XO , YO , IXS , DI SCRT , NLK , BUFDIS , PHI S , UBARNK , 

1 GDEPNM , GDEPPl , GDEPP2 .DBARI3 , SIGAPK, SIGEPK) 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 


C 

C 

c 

c 

cc 


THIS SUBROUTINE COMPUTES GRAVITATIONAL DEPOSITION FOR A GIVEN 
RANGE AND BEARING (XO,YO) OVER ALL BOUNDARY LAYERS. 


BEGIN COMMON AREA **** 

04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAHMAI,GAMMAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE , GOOD , TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MOD EL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY ,XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE, IPRINT , SIGMAR, SIGMER,LSITE,BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NDISO ,NTISO , FILE (3 ) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,ipllntU) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL I SNDFO , CRT , MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS .MODEL6 
INTEGER RUNNUM , RT , CL , C S 

COMMON /CTRFL/ IFLG, RUNNUM, NUM,NLAYS,NBK,QC,QT, HEAT, ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 
SIGZ,ISNDFO,CRT, LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT ( 3 ) 

.ALTSV, BATCH, CL(14),CS(10) , GASSET, lAGAIN, 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , 

MINUSl ,MINUS9 ,MINS1 ,MINS9 , 

MODEL4 , MODELS , MODEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24) ,TPROPC,IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2), 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP 
CLRLNE , INSLNE , DELINE , 

IESCAJ(3),NULL,IBLNK, 

IPAR(S ) , ICU , lYS J , lYESJ , INJ , INO J , NAMEP (3) 


SSOOOOOO 

SSOOOOlO 

SS000020 

SS000030 

-SS000040 

SSOOOOSO 

SS000060 

SS000070 

SSOOOOSO 

-SS000090 


SSOOOlOO 

SSOOOllO 

SS000120 

SS000130 

SS000140 

SSOOOISO 

SS000160 

SS000170 

SS000180 

SS000190 

SS000200 

SS000210 

SS000220 

S5000230 

SS000240 

SS0002SO 

SS000260 

SS000270 

SS000280 

SS000290 

SS000300 

SS000310 

SS000320 

SS000330 

SS000340 

S50003S0 

SS000360 

SS000370 

SS000380 

SS000390 

SS000400 

SS000410 

SS000420 

SS000430 

SS000440 

SS0004S0 

,SS000460 

SS000470 

SS000480 

SS000490 
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c VEHICLE PARAMETERS qsnnn<^nn 

COMMON /VCLPR/ VPAR(17) SSOOOSin 

C time PARAMETERS S5000520 

COMMON /TIME/ JTIME, JDAY, JYEAR. ISTIME, ISDAY, ISYEAR,LTIME, S5000530 

LDAY,LYEAR,ISM0N(2),JM0N(2),LM0N(2),LSDT(2) S5000540 

c SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S5000550 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S5000560 

• ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S5000570 

c layer parameters 530QQ33Q 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,0(29) ,RISTIM(29) ,SIGXO(29) , S5000590 

• SIGYO(29) S5000600 

^ CALCULATED BOUNDRY DATA (FOR NEW LAYERS) SSOnOfilD 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S5000620 

C CALCULATED NEW LAYER PARAMETERS S5000630 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) .S5000640 

• SPEEDN(32) S5000650 

c CONVERSION FACTORS qqnnnfi^n 

^ COMMON /CNVRT/ QC0NV(4) .QPDEPH S5000670 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************s 5 O 0 OfiQn 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S5000700 

C READ/WRITE BUFFER ^ ^ qsnonvJn 

^ R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S50007'^0 

c 

C EQUIVALENCE STATEMENTS qsnnOTSn 

EQUIVALENCE (I lU , IPAR( 1 ) ) , (lOU, IPAR(2) ) , (IPUl , IPAR(3) ) S5000760 

,(IPU2.IPAR(4)),(IPU3.IRaR(5)) S5000770 

EQUIVALENCE (MAXDEP,GRVSET) , (IFRMT(l) ,IFRMT1) S5000780 

r**** r. XT T^ ^ TT ^ « S5000790 

END OF COMMON AREA ****55000800 

LOGICAL DISCRT, FIRST S5000820 

DIMENSION CI(50) ,YPI(50) ,SIGYI(50) ,ALATM(50) ,YMCL(2) ,AVGSY(2) S5000830 

DIMENSION RANGE (30 , 1 ) , BEARNG (30 , 1 ) , SIGYBR(30 , 1) , VALUES (30,1), S5000840 

1 PHIS(l) ,UBARNK(1) ,SIGAPK(1) ,SIGEPK(1) ,MILK(2) ,BUFDIS(1) S5000850 

^ DIMENSION GDEPRT(20),GDEPNM(10,1),GDEPP1(1),GDEPP2(1),DBARI3(1) S5000860 

C VPAR(16) = % OF AL203 IN VEHICLE. qsnnossn 

EQUIVALENCE (VPAR(16) ,AL203) S5000890 

EQUIVALENCE (PLUS, RANGE) , (PLUS(181) , BEARNG) , S5000900 

1 (PLUS(361),SIGYBR),(PLUS(547), VALUES) S5000910 

^ qqnnnoon 

DATA MILK /5,4/, SQR2PI /O. 3989423/ S5000930 

DATA RAD /. 01745329/, RADI/57.29578/, TWOPI/6. 283185/ S5000940 

C*** INITIALIZE S5000950 

^ iiNiiiALi^h. S5000960 

XOP = XO S5000970 

AUr AO 85000980 

10 CONTI J 


230 



no 


DO 20 I = 1,50 
CI(I) = 0.0 
DO 20 J=1,NVS 
20 GDEPNM(J,I) =0.0 
INDM = 1 
SUMSY =0.0 
C 

C*** BEGIN LOOP OVER MAJOR BOUNDARY LAYERS, 

C 

DO 210 ILK = l.NLK 
NSOURC = 0 
ILKP3 = ILK + 3 

IF(NLK .EQ. 2) ILKP3 = MILK(ILK) 

JF = NLAYS + ILK 
IBOT = LAYBOT(ILK) 

FOR SECOND BOUNDARY LAYER ADJUST BOTTOM LAYER INDEX TO 
TOP OF FIRST BOUNDARY LAYER. 

IF(ILK .GT. 1) IBOT = LAYTOP(l) + I 
ITOP = LAYTOP(ILK) 

ALTTOP = ALT(ITOP+l) 

30 CONTINUE 
C 

IF(IRUN .EQ. 4) WRITE (lOU, 9001) ILK, XO,YO, IBOT, ITOP, DIRN ( JF) , 

1 SIGEPN(JF) 

c 

C** BEGIN LOOP OVER METEOROLOGICAL LAYERS WITHIN BOUNDARY LAYER, 

C 

- DO 200 M = IBOT, ITOP 
GDEP =0.0 
DO 40 J=1,NVS 
40 GDEPRT(J) =0.0 

IF(IRUN .EQ. 4) WRITE(IOU,9006) M 
IF(Q(M) .LE. 0.0) GOTO 190 
C 

IF (.NOT. (DISCRT .OR. LOOP .GT. 0)) GO TO 50 
C* CALL SUBROUTINE TO COMPUTE CLOUD-RECEPTOR POSITION (XS,YS) 

C* AND DOWNWIND & CROSSWIND DISTANCES (X,Y). 

C 

A1 = DIRN(M)*RAD+PHIS(M) 

CALL COORD(Al ,M,XO,YO,XS,YS,X,Y) 

C UPWIND? 

IF(IFLG .LT. 0) GOTO 190 

GO TO 60 
C 

C* ADJUST DOWNWIND & CROSSWIND DISTANCES DUE TO CLOUD INCLINATION. 
C RAD CONVERTS DEGREES TO RADIANS. 

50 PHISM = (DIRN(M)+180.0)*RAD + PHIS(M) 

IF(PHISM .GT. TWOPI) PHISM = PHISM - TWOPI 
IF(PHISM .LE. 0.0) PHISM = PHISM + TWOPI 
THETC = DY(M)*RAD 
SR = ABS (PHISM - THETC) 

IF (SR .GT. PI) SR = TWOPI-SR 
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SR = ABS(PI-SR) 

A1 = DX(M) 

SS = PI - (SR + ARSIN(A1*SIN(SR)/X0P)) 

X = A1*A1 + XO*XO - 2.0*A1*XO*COS(SS) 

IF(X .LE. 0.0) GOTO 190 
X = SQRT(X) 

SK = 1.0 

IF(ABS(PHISM - THETC) .GT. PI) SK = -1.0 
IF(PHISM .LT. THETC) SK = -1.0*SK 
Y = THETC + SK*SS 
IF(Y .LE. 0.0) Y = Y + TWOPI 
IF(Y .GT. TiroPI) Y = Y - TWOPI 
60 CONTINUE 
C 

C* CALL SUBROUTINE TO COMMUTE SIGMAS. 

C 

CALL SIGMA(X,M,JF,1,SIGAPK(M) ,SIGEPK(M) ,PHIS(M)*RADI) 
,IF(SIGYNK .LE. 0.0) GOTO 190 
C 

C* COMPUTE LATERAL TERM FOR DISCRETE RECEPTORS. 

C 

IF(.NOT. (DISCRT .OR. LOOP.GT.O)) GOTO 70 
A1 = Y/SIGYNK 

IF(ABS(A1) .GT. 10.0) GOTO 190 
ALAT = EXP(-.5*A1*A1) 

70 CONTINUE 
C 

C* INITIALIZE VARIABLES FOR MODEL EQUATIONS. 

.70710678 = l./SQRT{2) 

UBARNL = UBARNK(M) 

UBARI = 1. /UBARNL 
A1 = BETA - 1.0 
IF(Al) 80,90,80 

80 SGEXS = l./(SIGEPK(M)*X**BETA) 

BSEXS2 = BETA*SIGEPK(M)*X**A1*SQR2PI 
GOTO 100 

90 SGEXS = l./(SIGEPK(M)*X) 

BSEXS2 = SIGEPK(M)*SQR2PI 
100 SGEXS2 = SGEXS*. 70710678 
ALTM = ALT(M) 

'ALTMI «■ ALT(M+1) 

QAS = Q(M)/((ALTM1-ALTM)*SIGYNK) 

VSSUM = 0.0 

C* BEGIN SUMMATION OVER SETTLING VELOCITY CATEGORIES. 

C 

DO 140 J = 1,NVS 
VSl = VS(J) 

VJXSUL = VS1*X*UBARI 
GAMMA = GAMMAP(J) 

GDEPRT(J) =0.0 
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C S5002060 

C* COMPUTE FIRST TERMS FOR MK + NK (BMPBN). S5002070 

C S5002080 

A1 = (ALTM1-VJXSUL)*SGEXS2 S5002090 

A2 = UlTM-VJXSUL)*SGEXS2 S5002100 

A3 = ERFXS(A1,A2) S5002110 

A4 = (ALTM1-VJXSUL)*SGEXS ' S5002120 

A4 = TEXP(A4) S5002130 

A5 = (ALTM-VJXSUL)*SGEXS S5002140 

A5 = TEXP(A5) S5002150 

C S5002160 

BMPBN = VS1*.5*UBARI*A3 - BSEXS2*(A4-A5) S5002170 

C S5002180 

C S5002190 

r S5002200 


IF(IRUN.EQ.4) WRITE(IOU,9002) J,M,XS,YS,X,Y,DIRN(M) ,SIGYNK,ALAT, S5002210 
1 UBARI ,VJXSUL, SGEXS ,BSEXS2 , SGEXS2 , ALTM, ALTMl ,A1 ,A2 ,A3 ,A4 ,A5 , BMPBN S5002220 




S5002230 

COMPUTE SUMMATION TERM FOR MK + NK 

(BMPBN). 

S5002240 



S5002250 

AI = 2.0 


S5002260 

GAM = 1.0 


S5002270 

SAALT = AI*ALTTOP 


S5002280 

SUM = 0.0 


S5002290 

FIRST = .TRUE. 


S5002300 
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llO CONTINUE 
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:A1 = SAALT - ALTMl + VJXSUL 


S5002330 

A2 = SAALT - ALTM + VJXSUL 
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All = A1*SGEXS2 
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A21 = A2*SGEXS2 
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A3 = ERFXS(A11 ,A21) 
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A4 = A1*SGEXS 


S5002380 

A4 = TEXP(A4) 
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A5 = A2* SGEXS 
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, A5 = TEXP(A5) 
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A6 = SAALT + ALTMl - VJXSUL 
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A7 = SAALT + ALTM - VJXSUL 
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A61 = A6*SGEXS2 
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A71 = A7*SGEXS2 
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A8 = ERFXS(A6i ,A71) 
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A9 = A6*SGEXS 
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A9 = TEXP(A9) 
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AlO = A7*SGEXS 


S5002490 

AlO = TEXP(AIO) 
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SUM - SUM + GAM*(VS1*.5*UBARI*A3 + 

BSEXS2*(A4-A5) 

S5002520 

1 + GAMMA* (VS 1*.5*UBARI*A8 

- BSEXS2*(A9-A10))) 

S5002530 



S5002540 

IF(FIRST) GOTO 120 


S5002550 

IF(ABS(SUM-SUML) .LT. l.E-6) GOTO 

130 

S5002560 

120 SUML = SUM 


S5002570 
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AI = AI + 2.0 
SAALT = AI*ALTTOP 
GAM = GAM--GAMMA 
FIRST = .FALSE, 

GOTO 110 

130 AI = BMPBN + SUM 

IF(A1 .LE. 0.0) GOTO 140 
A2 = (1.0-GAMMAP(J))*FS(J)*A1 
VSSUM = VSSUM + A2 
GDEPRT(J) = A2*DBARI3(J)*QAS 

IF(IRUN .EQ. 4) WRITE(IOU,9005) J,M,SUM, VSSUM, AI ,A2,DBARI3(J) , 

1 GDEPRT(J) 

140 CONTINUE 
C 

C* COMPUTE FINAL TERMS FOR MK + NK AND GRAV. DEP. 

C 

GDEP = QAS*VSSUM 

IF(.NOT. (DISCRT .OR. LOOP.GT.O)) GOTO 160 
GDEP = GDEPAALAT 
DO 150 J = l.NVS 
150 GDEPRT(J) = GDEPRT(J)*ALAT 
160 IF(GDEP .LE. 0.0) GOTO 180 
CI(INDM) = GDEP 
DO 170 J = l.NVS 
170 GDEPNM(J,INDM) = GDEPRT(J) 

SIGYI(INDM) = SIGYNK 
SUMSY = SUMSY + SIGYNK 
YPI(INDM) = Y 
NSOURC = NSOURC + 1 
INDM = INDM + 1 
180 CONTINUE 
C 

c 

c 

190 YF(IRUN .EQ. 4) WRITE(IOU, 9003) LOOP, VSSUM, Q(M) ,QAS,SIGYNK,GDEP 
1 ,(GDEPRT(J),J=1,NVS) 

C* END OF MET. & MAJOR BOUNDARY LAYER LOOPS. 

200 CONTINUE 

IF (ILK .EQ. 1) AVGSY(l) = SUMSY /NSOURC 
210 CONTINUE 

AVGSY(2) = SUMSY/ (INDM-1) 

IF(L00P .NE. 0) GOTO 250 
C 

C** GET GRAVITATIONAL DEPOSITION OVER ALL MET. LAYERS. 

C** FOR MAX. CENTERLINE, COMPUTE MAXIMUM VALUE AND LOCATION. 

C** FOR DISCRETE, SUM GRAV. DEP. OVER ALL MET. LAYERS. 

C 

IF (INDM .LT. 2) GOTO 430 
IF(DISCRT) GOTO 340 
C 

C* CALL SUBROUTINES TO FIND MAXIMUM VALUE AND LOCATION 
C* OVER BOUNDARY LAYER. 
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N = INDM - 1 
CALL CROSS (YPI.N) 

DO 220 I = 1 ,N 
220 YPl(I) = YPI(I)*X0 
ILK = 1 

IF (NLK .EQ. 1) NSOURC = 0 
N = INDM - NSOURC - 1 

230 CALL REODR(CI,YPI,SIGYI,GDEPNM, 1 ,N,NVS) 

^ CALL GDEPR(CI,YPI,SIGYI,N,GDEP,YMCL(ILK)) 

IF(ILK .EQ. 2.0R.NLK.EQ.1) GOTO 240 
ILK = 2 
N = INDM - 1 
GOTO 230 

c** LOOP-BACK LOGIC. GO BACK AND CALCULATE EXACT RESULTS AT 
C** MAXIMUM LOCATION. 

240 LOOP = 1 

YO = YMCL(1)/X0P*RADI 
GOTO 10 

250 IF (LOOP .NE. 1) GOTO 290 
C** SUM RESULTS FOR LAYER 1. 

IF (NLK .EQ. 1) NSOURC = 0 
N = INDM - NSOURC - 1 
ILKP3 = 4 

IF (NLK .EQ. 2) ILKP3 = 5 
GDEP =0.0 
DO 260 M = 1,N 
260 GDEP = GDEP + CI(M) 

GDEPP =0.0 
DO 280 J = l.NVS 
GDEPP 1(J) =0.0 

270 GDEPPl(J) = GDEPPl(J) + GDEPNM(J.M)*SQR2PI*AL203 
280 GDEPP = GDEPP + GDEPPl(J) 

GOTO 330 
290 CONTINUE 

C** SUM RESULTS FOR LAYER 2. 

N = INDM - 1 
ILKP3 * 5 

IF(NLK .EQ. 2) ILKP3 = 4 
GDEP =0.0 
DO 300 M = 1,N 
300 GDEP = GDEP + CI(M) 

GDEPP =0.0 
DO 320 J = l.NVS 
GDEPP2(J) =0.0 
DO 310 M = l.N 

310 GDEPP2(J) = GD£PP2(J) + GDEPNM(J,M)*SQR2PI*AL203 
320 GDEPP = GDEPP + GDEPP2(J) 

C* STORE RESULTS IN ARRAYS. FOR TWO LAYERS. SUM IS IN INDEX 4 & 
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c* 

c* 

c 


LAYER 1 IS IN INDEX 
SUBTRACT 3 FROM THIS 


5. FOR ONE LAYER, LAYER 1 IS IN INDEX 
INDEX FOR PARTICLE RESULTS. 


4. 


C 


C 


c 


330 VALUES (IXS,ILKP3) = GDEP*1000. 0*SQR2PI*AL203 
ILKPM3 = ILKP3 - 3 
VALUES (IXS.ILKPM3) = GDEPP 
SIGYBR(IXS,ILKP3) = AVGSY(LOOP) 
SIGYBR(IXS,ILKPM3) = AVGSY(LOOP) 

RANGE. 


RANGE (IXS.ILKP3) = XO 
RANGE (IXS,ILKPM3) = XO 
BEARING. 

IF(YO .GT. 360.0) YO = YO - 360.0 


IF(YO .LE. 0.0) YO = YO + 360.0 
BEARNG(IXS,ILKP3) = YO 
BEARNG(IXS,ILKPM3) = YO 

IFdRUN .EQ. 4) WRITE (lOU. 9007) LOOP, ILKP3.GDEP, GDEPP, XO,YO 
, AVGSY(LOOP) 

IF(LOOP .EQ. 2.0R.NLK.EQ.1) GOTO 420 
LOOP = 2 

IF(ABS(YMCL(2) - YMCL(l)) .LT. l.E-3) GOTO 290 
YO = YMCL(2)/XOP*RADI 
GOTO 10 


C* DISCRETE RECEPTOR LOGIC. 

C* SUM GRAV. DEP. OVER ALL MET LAYERS AND STORE RESULTS. 

C* INDEX 1 = LAYER ONE, 2 = LAYER TWO, 

C* INDEX 3 = PARTICLES LAYER ONE, 4 = PARTICLES LAYER TWO. 


340 N = INDM - NSOURC - 1 

IF (NLK .EQ. 1) N INDM-1 
GDEP =0.0 
DO 350 I = 1,N 
350 GDEP = GDEP + Cl (I) 

GDEPP =0.0 
DO 370 J = 1,NVS 
GDEPPI(J) =0.0 
DO 360 M = 1,N 

360 GDEPPl (J) = GDEPPI(J) + GDEPNM(J,M)*SQR2PI*AL203 
370 GDEPP = GDEPP + GDEPPl (J) 

BUFDIS(l) = GDEP*1000.0*SQR2PI*AL203 
BUFDIS(3) = GDEPP 
IF (NLK .EQ. 1) GO TO 420 
N = INDM - 1 
GDEP =0.0 
DO 380 I = 1,N 
380 GDEP = GDEP + Cl (I) 

GDEPP = 0.0 
390 DO 410 J = 1,NVS 
GDEPP2(J) =0.0 
DO 400 M = 1,N 

400 GDEPP2(J) = GDEPP2(J) + GDEPNM(J,M)*SQR2PI*AL203 
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410 GDEPP = GDEPP + GDEPP2(J) 

BUFDIS(2) = GDEP*1000. 0*SQR2PI*AL203 
BUFDIS(4) = GDEPP 

420 IFdRUN .EQ. 4) WRITE(I0U, 9004) IXS,INDM,NS0URC.AVGSY,TOGL,AL203, 
1 GDEP , GDEPP , (VALUES (IXS,J),J=1>6).( BEARNG ( IXS , J ) , J- 1 , 6 ) 

430 CONTINUE 
C 

c*** RETURN 


C 

CF** 
CF 


RETURN 

FORMAT STATEMENTS. 
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9001 FORMAT(52HO DIAGNOSTICS FOR MAJOR BOUNDARY LAYER AND LOCATION. ,16 . S500 

1 2F10.3/24H IB0T,IT0P.DIRN,SIGEPN=.2I6,1P2E12.5) ornn/^in 

9002 F0RMAT(47H FIRST TERMS FOR MK + NK FOR SETTLING CATEGORY, 13, - 

11^ MET. LAYER,I3/33H XS,YS,X,Y,DIRN(M) ,SIGiraK,ALAT =. 1P7E12. 5/S5004320 


X. • J. t — , , . ~ 

2 35H UBARI,VJXSUL,SGEXS,BSEXS2,SGEXS2=,5E12.5/ 

3 34H ALTM,ALTM1,A1,A2,A3,A4,A5,BMPBN=,8E12.5) 

9003 FORMAT(41H LOOP, VS SUM, Q (M) ,QAS,S IGYNK, GDEP /GDEPP -,I4, 1P5E13.5/ 

9004^FOWlATa8H\ESULTS FOR RANGE, 13, 15H INDM,NSOURC =.216/ 

1 41H AVGSY ( 1-2) ,YMCL( 1-2) ,AL203, GDEP, GDEPP -.1P7E12.5/ 

2 15H VALUES(l-6) =,6E13.5/15H BEARNG(l-6) =,6E13.5) 

9005 FORMAT(45H FINAL SL^MMATION TERMS FOR SETTLING CATEGOR » > 

112H, MET. LAYER, I3/32H SUM, VS SUM, A1 ,A2,DBARI3, GDEPP »,1P6E12.5) 

9006 FORMAT (19H0*** FOR MET. LAYER, 13) _ 

9007 FORMAT(50H GRDEP-STORED-LOOP,ILKP3, GDEP, GDEPP, X0,Y0, AVGSY -,2I4, 

1 1P5E13.5) 

END 
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SUBROUTINE GDEPR(CI , YPI , SIGYI , NSOURC , RCHI , RYC) 

. , UPDATE: 8213 SOURCE: 16 DEC 81 LOCATION: KSC 


C 

C THIS SUBROUTINE CALCULATES THE MAXIMUM CENTERLINE 

C GRAVITATIONAL DEPOSITION. 

C 

C 

C 

DIMENSION CI(1),SIGYI(1),YPI(1) 

C 

ISTR= 1 

RCHI=0.0 

RY=0.0 

C CALCULATE THE NUMBER OF SOURCES IN A GROUP 

10 SMIN=SIGYI(ISTR) 

I=ISTR 

20 IF(I.GT. NSOURC) GO TO 120 
IFd.EQ. NSOURC) GO TO 30 
J=I+1 

TMP1=YPI(I)-YPI(J) 

TMP2=1. 18*(SIGYI(I)+SIGYI(J)) 

IF(TMP1.GT.TMP2) GO TO 30 
1 = 1+1 
GO TO 20 
30 CONTINUE 

SMIN=SIGYI(ISTR) 

IFdSTR.EQ. NSOURC) GO TO 50 
IF(ISTR.EQ.I) GO TO 50 
DO 40 M=ISTR+1,I 
40 SMIN=AMIN1(SMIN, SIGYI (M)) 

50 YINC=.08*SMIN 
YY=YPI(ISTR) 

60 YCHI=0.0 

IF(YY.LT.YPId)) GO TO 100 
DO 70 M=l, NSOURC 
EX=(YY-YPI(M))/SIGYI(M) 

YCHI=YCHI+CI (M) *TEXP (EX) 

70 CONTINUE 

80 IF(YCHI.LT.RCHI) GO TO 90 
RCHI=YCHI 
RYC = YY 
90 YY=YY-YINC 
GO TO 60 
100 CONTINUE 
110 ISTR=I+1 
GO TO 10 

120 IF(RCHI.LE.O.O) RYC = 0.0 
RETURN 
END 
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c 

c 


SUBROUTINE REODR ( Cl , YEAR , SIGYI , GDEP , IFR , ITO , NVS ) 

, , UPDATE: 8213 SOURCE: 16 DEC 81 LOCATION: KSC 

THIS ROUTINE REORDERS THE SOURCE CLOUD VALUES BASED ON DESCENDING 
YEAR. 

DIMENSION CI(1) ,YBAR(1) ,SIGYI(1) ,GDEP(10,1) 


IF (ITO- IFR ,LT. 1) RETURN 
DO 20 I = IFR,IT0-1 
DO 20 J = I+1,IT0 
iF(YBAR(l) .GT. YBAR(J)) GOTO 20 
A1 = YBAR(I) 

VBAR(I) = YBAR(J) 

YBAR(J) = A1 
A1 = SIGYI(I) 

SIGYI(I) = SIGYI(J) 

SIGYI(J) = A1 
A1 = Cl (I) 

CI(I) = CI(J) 

CI(J) = A1 
DO 10 N = l.NVS 
A1 = GDEP (N, I) 

GDEP(N,I) = GDEP(N.J) 

10 GDEP(N,J) = A1 
20 CONTINUE 
RETURN 
END 


S5200000 

S5200010 

S5200020 

S5200030 

S5200040 

S5200050 

S5200060 

S5200070 

S5200080 

S5200090 

S5200100 

S5200110 

S5200120 

S5200130 

S5200140 

S5200150 

S5200160 

S5200170 

S5200180 

S5200190 

S5200200 

S5200210 

S5200220 

S5200230 

S5200240 

S5200250 

S5200260 

S5200270 
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REEDM SOURCE MODULE &RSUBM 


C 

C 

C 

C 

C 

Cc 

c**** 


c 


c 


c 


c 


FTN4 S5300000 

SUBROUTINE COORD(DIRCTN,L,XR,YR,XS,YS,X,Y) S5300010 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S5300020 

: S5300030 

S5300040 

THIS SUBROUTINE TRANSLATES AND ROTATES THE AXIS TO MAKE THE MEAN S5 300050 
WIND DIRECTION THE POSITIVE X AXIS S5300060 

S5300070 

S5300080 

S5300090 


BEGIN COMMON AREA 


****55300100 


04/02/82 

MATH PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GA1-1MAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , T IMAV , I S IG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR , SIGMER, LSITE , BOTLAY , 

ZRK , DECAY , GOOD , NCI SO , NDI SO , NTISO , FILE (3) 

, RAINRT , LAMBDA , TIMl, DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14),SIGPP(29),SIGLL(29),VS(20), 
FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES, 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODEL5 , MODEL6 

INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT ( 3 ) 

,ALTSV, BATCH, CL(14) ,CS(10) , GASSET, lAGAIN, 

I CHAR (12), IDXCL, IDXCS , TERROR (5) , IFRMT (80) , 

MINUS 1 ,MINUS9 , MINS 1 ,MINS9 , 

MODEL4 , MODEL5 , MODEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24) ,TPROPC,IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,OFF,BLNKNG, INV,ULINE, INVNDR, 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 
CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2), 


S5300110 

S5300120 

S5300130 

S5300140 

S5300150 

S5300160 

S5300170 

S5300180 

S5300190 

S5300200 

S5300210 

S5300220 

S5300230 

S5300240 

S5300250 

S5300260 

S5300270 

S5300280 

S5300290 

S5300300 

S5300310 

S5300320 

S5300330 

S5300340 

S5300350 

S5300360 

S5300370 

S5300380 

S5300390 

S5300400 

S5300410 

S5300420 

S5300430 

S5300440 


TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP ,85300450 
CLRLNE, INSLNE, DELINE, S5300460 

IESCAJ(3) ,NULL,IBLNK, S5300470 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S5300480 

•VEHICLE PARAMETERS S5300490 
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comoN /VCLPR/ VPAR(17) qs^nn^io 

C TIME PARAMETERS 

COMMON /TIME/ JTIME, JDAY , JYEAR, ISTIME.ISDAY , ISYEAR.LTIME, qc^nnS'^O 

LDAY,LYEAR,ISM0N(2).JM0N(2),LM0N(2),LSDT(2) S5300530 

C 1 SOUNDING/ FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COmON /FRCST/ ALT(30),DIR(30),SPEED(30),TEMP(30),PRESS(30), 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S5300570 

^ COMMON^ /LMER^XX,DYY,DX( 29) ,DY(29) ,Q(29) ,RISTIM(29) , SIGX0(29) , ^5300580 

SIGYO(29) b:)juuD^u 

C 1 CALCULATED BOUNDRY DATA (FOR NEW LAYERS) qrnnnA?n 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) c„nnfi9n 

r rATCUTATED NEW LAYER PARAMETERS b5JUUD/u 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) . SIGAPN(32) , SIGEPN(32) , S5300630 

SPEEDN(32) S5300640 

C CONVERSION FACTORS oqqnnfiftn 

COMMON /CNVRT/ QCONV(A) ,QPDEPH 353006% 

C**********C0MM0N BUFFER ARRAY FOR COMMON mODIFICATION******************S5300680 

COMMON /EXTRA/ NCOM(l) . NTOTAL(l) . PLUS(900) 

C__— re^/URITE BUFFER^^ ^ ^ ^ ^ + 2 * 900 = 3879S5300710 

0*******^***********=^-****************************************^ 

C 95300740 

C EQUIVALENCE STATEMENTS q?qnn75n 

EQUIVALENCE(IIU,IPAR(D) , (I0U,IPAR(2)) , (IPUl ,IPAR(3) ) qS9nn760 

,(IPU2.IPAR(4)),(1PU3,IPAR(5)) 

EQUIVALENCE (MAXDEP .GRVSET) . (IFRMT(l) .IFRMTl) 

C S5300790 

C**** end of common AREA ****s%00810 

_ S5300820 

IFLG-O S5300830 

RAD = Pl/180.0 q-^^nnSAO 

B=AMOD(YR,360.0)*RAD «^nn%0 

XP=XR*SIN(B) ^3^00360 

YP=XR*C0S(B) S5300870 

B-COS(DIRCTN) S5300880 

A=SIN(DIRCTN) 95300890 

C=DY(L)*RAD 

XDX=DX(L)*SIN(C) S5300910 

YDY=DX(L)*COS(C) 35300920 

X1=XP-XDX S5300930 

Y1=YP-YDY 35300940 

X— X1*A Y1*B 35300950 

Y=X1*B-Y1*A 35300960 

■ IF(X.GT.O.O) GO TO 10 35300970 

IFLG=-1 S5300980 

GO TO 20 S5300990 

10 XS=SQRT(X1*X1+Y1*Y1) 35301000 

YS~0.0 c'^'^ninio 

IF(X1.EQ.0.0 .AND. Yl.EQ.0.0) GO TO 20 
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YS- (0. 5*PI) -ATAN2 (Y1 ,X1) S5301020 

IF(YS.GE.O.O) GO TO 20 S5301030 

YS=YS+2.0*PI S5301040 

20 RETURN S5301050 

S5301060 
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SUBROUTINE SIGMA(XP ,M, JF, ISIGMA, SIGAPP.SIGEPP.DDIRP) S54000I0 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S5400020 

Cc „ ^ w « o M A B p A ****S5400030 

C**** BEGIN COMMO S5400040 

C 04/02/82 S5400050 

Q— — MATH PARAMETERS AND CONSTANTS <?S400060 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S5400070 

C INPUT OPTIONS S5400080 

REAL LAMBDA S5400090 

INTEGER FILE, GOOD, TITLE oc/nninn 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, csiOOllO 

ISHAPE.GAfMAX.GAMMAY.GMMAZ.ALPHA.BEIA. iS 

XEY,XEZ,XLEY,TIHAV,ISIG,ICALC.CALHT. S540020 

IPLACE.IPEINT.SIGMAR.SIGMER.LSIIE.BOTIAY, S5400 30 

ZEK, DECAY, GOOD, NCISO,HDISO,llTISO,FILE(3) S5400UO 

.RAISRT, LAMBDA, TIM1,DUMT,NVS,IVERSN,L0CATN(2) 

,IPLLST(4),GAMb«lP(30),HM(2),CISO(10).DISO 10), “ 

TISO(10),Tmi(14),SIGPP(29),SIGLL(29),VS(20), S5400 70 

FS(20),MDLNAM(12),DBAR(20) “400180 

c COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES qS400’00 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S5400210 

. M0DEL4,M0DEL5,M0DEL6 S5400220 

J™/"1kG^;SNNUM.NUM,NLAYS,NBK^ 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , ecAnn^SO 

SIGZ, ISNDFO, CRT, LAYTOP (3). ITDU, KEEP S5400250 

.MIXING, MAXDEP, LAYBOT(3) csAnn270 

,ALTSV, BATCH, CL(14),CS(10), GASSET, lAGAIN, qLnn?80 

ICHAR(12),IDXCL,IDXCS,IERROR(5).IFRMT(80). qsAnn290 

MINUS1.MINUS9,MINS1,MINS9, «/nn^nn 

M0DEL4,M0DEL5,M0DEL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S5400300 

RT(24),TPR0PC,IDXRT 

C 1 TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S5400330 

■comON/SwiS(2?'rE(2),BL™G(2),IRV(2),I»VHF(2) S5400360 

SrTAB?,SB!cmAB,CDRSUP,CURSD»,GURLFT,CLRDSP,S54^ 
CLRLNE.INSLNE. DELINE. 

IESCAJ(3),NULL,IBLNK, ^5400^00 

IPAR(5),ICU,IYSJ,IYESJ,INJ.INOJ,NAMEP(3) |s400420 

C 1 VEHICLE PARAMETERS S5400430 

COMMON /VCLPR/ VPAR(17) S5400440 

^ COMMON^/TIMErJTIME^JDAY.JYE^^ I 54 OO 46 O 

C ■ SOUNDING/FOR^A™EtXwGIC^ data’ (INITIAL ^^EVELS) 

' COHMoHerS/ ALT(30) ,DIR(30) ,SPEED(30) tmPOO ,PRESS(30) . S 00480 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S5400500 

C LAYER PARAMETERS 
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COMMON /tAm/ D^.DYY.I>X(29),DY(29),q(29).RISTIM(29,.SIGX0(29). S5A005I0 

^ CALCULATED BOUNDRY DATA (FOR NEW LAYFR<;'^ S5400520 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) 

C CALCULATED NEW LAYER PARAMETERS 

COMMON /NLYER/ ODIR(32) .DIEN(32) ,OSPEED(32) .SIGAPN(32) ,SIGEPN(32) . S54 

c CONVERSION FACTORS S5 4005 70 

COMMON /CNVRT/ QCONV(4) ,OPDEPH S5400580 

^ '< K n.rn S5400590 

C READ/WRITE BUFFER «iUlALU7, PLUS(900) S5400620 

C A R R A Y = 2077 + 1 + i ^ o * S5400630 

C EQUIVALENCE STATEMENTS" S5400660 

EQUIVAlENCE(ira.IPAR(l)),(IOU,IPAR(2)).(ipni,ipAR(3)) 

• *(^P^2,IPAR(4)), (IPU3,IPAR(5)) S5400680 

EQUIVALENCE (MAXDEP.GRVSET) , (IFR>iT(l) IFRMTn S5400690 

DATA RAD/. 01745329/ ^ U7 .IFRMTl) S5400700 

C S5400710 

^**** ENDOFCOMMONAREA S5400720 

Cc N A R E A ****S5400730 

X =• 0.0 S5400740 

MMM = 1 S5400750 

SIGZ=0.0 S5400760 

SIGY - 0.0 S5400770 

SIGX - 0.0 S5400780 

A1 - 1.0 S5400790 

A2 » SIGYO(M) S5400800 

A3 = SIGAPP S5400810 

B3 = SIGEPP S5400820 

A4 » ALPHA S5400830 

B4 » BETA S5400840 

A5 » DDIRP S5400850 

A6 * SIGXO(M) S5400860 

RL - 0.0 S5400870 

IFpSPEED(M).GT.O.O) RL - . 28*X*DSPEED(M) /SPEEDN(M) S5400890 

10 IF((A4-1.0).EQ.0.0) go to 20 S5400900 

A1 = 1.0/A4 S5400910 

IF(MMM. EQ.2) GO TO 30 S5400920 

IF((A2-A3*XRY).GT.O.O) GO TO 30 S5400930 

20 XY =- A2/A3 S5400940 

GO TO 40 S5400950 

30 XY - A4*XRY*(A2/(A3*XRY))**A1+XRY*(1.0-A43 

40 IF(MMM.EQ. 1) XY » XY-XLRY S5400970 

IF(XY.LT.O.O) XY => 0.0 S5400980 

IF((A4-1.0).EQ.0.0) go to 50 S5400990 

T1 = (X+XY-XRY*(1.0-A4))/(XRY*A4) 

IF(TI.LE.O.O) go to 70 S5401010 

S5401020 
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T1 = A3*XRY*T1**A4 
GO TO 60 

50 T1 = A3*(X+XY) 

60 T2 = ABS(A5)*X*4.0589052E-3 
SIGY = SQRT(T1*T1+T2*T2) 

70 SIGX=SQRT(RL*RL*.05408329+A6*A6) 

IF(N.EQ.l) GO TO 90 
IF((B4-l.O).EQ.0.0) GO TO 80 
T1 = X/XRZ 

IF (T1 ,LT. 0.0) GO TO 90 
SIGZ = B3*XRZ*T1**B4 
GO TO 90 
80 XZ = X 

SIGZ = B3*XZ 
90 CONTINUE 

IF(MMM.EQ.2) GO TO 110 
N = 2 

X = XP , , 

MMM = 2 

T1 = (DIRN(M)-DIRN(JF))*RAD 
A1 = 1.0 
T2 = SIN(Tl) 

T1 = COS(Tl) 

A2 = SQRT((SIGX*T2)**2+(SIGY*T1)**2) 

IF(ISIGMA .EQ. 1) GOTO 100 
A3 = SIGAPN(JF) 

B3 = SIGEPN(JF) 

A5 = DDIR(JF) 

100 A4 = ALPHA 
B4 = BETA 

A6 = SQRT((SIGX*T1)**2+(SIGY*T2)**2) 

RL = 0.0 

IF(DSPEED(JF).GT.O.O) RL = . 28*X*DSPEED(JF) /SPEEDN(JF) 
GO TO 10 

no SIGXNK = SIGX 
SIGYNK = SIGY 
RETURN 
END 


S5401030 

S5401040 

S5401050 

S5401060 

S5401070 

S5401080 

S5401090 

S5401100 

S5401110 

S5401120 

S5401130 

S5401140 

S5401150 

S5401160 

S5401170 

S5401180 

S5401190 

S5401200 

S5401210 

S5401220 

S5401230 

S5401240 

S5401250 

S5401260 

S5401270 

S5401280 

S5401290 

S5401300 

S5401310 

S5401320 

S5401330 

S5401340 

S5401350 

S5401360 

S5401370 

S5401380 

S5401390 

S5401400 
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FUNCTION ERFXS(A,B) 

. , UPDATE: 8213 SOURCE: 02 OCT 79 LOCATION: KSC 

C 

c 

C CALCULATE ERF(A) - ERF(B). 

C 

C 

c 

C HPL = LOWER LIMIT - HPU = UPPER LIMIT. 

C 

LOGICAL DONE 

DATA HPL, HPU / l.E-10,5.0 / 

ERF(X) = l+X*(.705230784E-l+X*(.422820123E-l+X*(.92705272E-2+ 
1 X*(. 1520143E-3+X*(.2765672E-3+X*.430638E-4))))) 

C 

DONE = .FALSE. 

C = A 

10 IF(C .LT. 0.0) GOTO 20 
1 = 0 
GOTO 30 
20 I = 1 
C = -C 

30 IF(C .GT. HPL) GOTO 40 
F = 1. 

GOTO 60 

40 IF(C .LT. HPU) GOTO 50 
F = 0.0 
GOTO 70 
50 F = ERF(C) 

F = (l./F)**16 
60 IF(I .EQ. 1) F = -F 
70 IF(DONE) GOTO 80 
C = B 
G = F 

DONE = .TRUE. 

GOTO 10 
80 CONTINUE 

ERFXS = F - G 

C ONE'S WILL NOT CANCEL IF A & B ARE OPPOSITE IN SIGN 
IF(A .LT. 0.0 .AND. B .GE. 0.0) ERFXS = ERFXS-2 
IF(A .GE. 0.0 .AND. B .LT. 0.0) ERFXS = ERFXS+2 
RETURN 
END 


S5500000 

S5500010 

-S5500020 

S5500030 

S5500040 

S5500050 

-S5500060 

S5500070 

S5500080 

S5500090 

S5500100 

S5500110 

S5500120 

S5500130 

S5500140 

S5500150 

S5500160 

S5500170 

S5500180 

S5500190 

S5500200 

S5500210 

S5500220 

S5500230 

S5500240 

S5500250 

S5500260 

S5500270 

S5500280 

S5500290 

S5500300 

S5500310 

S5500320 

S5500330 

S5500340 

S5500350 

S5500360 

S5500370 

S5500380 

S5500390 

S5500400 

S5500410 

S5500420 
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FUNCTION TEXP(A) S5 600000 

. , UPDATE: 8213 SOURCE: 11 FEB 80 LOCATION: KSC S5600010 

S5600020 

IF(ABS(A) .GT. 10.0) GOTO 10 S5600030 

TEXP = EXP(-.5*A*A) S5600040 

RETURN S5600050 

10 TEXP = 0.0 S5600060 

RETURN S5600070 

END S5600080 
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SUBROUTINE CROSS (A, N) 

S5700000 


. , UPDATE: 8213 SOURCE: 10 NOV 81 LOCATION: KSC ' 

S5700010 


ROUTINE TO ELIMINATE CROSSOVER PROBLEMS 

S5700020 


DIMENSION A(l) 

S5700030 

S5700040 


I = 1 

S5700050 

10 

1 = 1+1 

S5700060 


IF (I .GT. N) GO TO 30 

S5700070 


IF (ABS(A(I)-A(I-D) .LE. 3. 141593) GO TO 10 

S5700080 


IF (A(I) .GT. A(I-D) GO TO 20 

S5700090 


A(I) = A(I)+6. 283185 

S5700100 


GO TO 10 

S5700110 

20 

A(I) = A(I)-6. 283185 

S5700120 


GO TO 10 

S5700130 

30 

CONTINUE 

S5700140 


RETURN 

S5700150 


END 

S5700160 
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FUNCTION ARSIN(X) 

CALCULATES THE ARCS IN OF X 

IF (X .GT. 1.0) X > 1.0 
IF (X .LT.-l.O) X =-1.0 
ARSIN » 1.570796 
IF (X-1.0) 10,20,10 
10 ARSIN = ATAN2(X,SQRT(1.0-X*X)) 
20 RETURN 
END 


S5800000 

S5800010 

S5800020 

S5800030 

S5800040 

S5800050 

S5800060 

S5800070 

S5800080 

S5800090 
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SUBROUTINE SHEAR (UBARNK , PHI S , SIGAPK , SIGEPK , IFCON) 

, UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 


C: 

C: 

C: 

C: 

C: 

C: 

C: 

C: 


PROGRAM DESCRIPTION: 

THIS PROGRAM CALCULATES THE INCLINATION OF THE CLOUD AXIS 
PHIS AND MEAN TRANSPORT WIND SPEED UBARNK FROM THE BOTTOM 
OF THE LAYER CONTAINING THE CALCULATION HEIGHT TO THE TOP 
OF THE SOUNDING. 


C: 

C: 

C 

C 

CC 

C**** 


COMMON AREA 


BEGIN 

04/02/82 

math parameters and CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR , SIGNER, LSITE , BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NDISO , NTISO , FILE (3) 

, RAINRT , LAMBDA , TIKI , DURAT , NVS . I VERSN , LOCATN ( 2 ) 
,IPLLNtU) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET . 

MODEL4 , MODELS ,MODEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING , MAXDEP , LAYBOT ( 3 ) 

, ALTS V, BATCH, CL (14) ,CS(10) , GAS SET, I AG AIN, 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , 

MINUS 1 ,MINUS9 ,MINS 1 .MINS9 , 

MODEL4 , MODELS .MODEL6 ,NNNEST,NNNTRY,LLNEST,LLNTRY 
RT(24) ,TPROPC,IDXRT 

terminal control CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,0FF,BLNKNG,INV,ULINE,INVNDR, 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

. CLRLNE,INSLNE, DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2), 


SS900000 
SS900010 
S5900020 
SS900030 
SS900040 
SS9000SO 
SS900060 
SS900070 
SS900080 
SS900090 
SS900100 
SS900110 
SS900120 
SS900130 
SS900140 
SS9001SO 
****SS900160 
SS900170 
SS900180 
SS900190 
SS900200 
SS900210 
SS900220 
SS900230 
SS900240 
SS9002S0 
SS900260 
SS900270 
SS900280 
SS900290 
SS900300 
SS900310 
SS900320 
SS900330 
SS900340 
SS9003S0 
SS900360 
SS900370 
SS900380 
SS900390 
SS900400 
SS900410 
SS900420 
SS900430 
SS900440 
SS9004S0 
SS900460 
SS900470 
SS900480 
SS900490 
SS900SOO 
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. TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP ,55900510 

CLRLNE.INSLNE, DELINE, S5900520 

lESCAJO) .NULL.IBLNK, S5900530 

. IPAR(5) ,ICU,IYSJ,IYESJ,INJ,IN0J,NAMEP(3) S59005A0 

C VEHICLE PARAMETERS S5900550 

COMMON /VCLPR/ VPAR(17) 55900560 

C TIME PARAMETERS 55900570 

COMMON /TIME/ JTIME, JDAY, JYEAR.ISTIME.ISDAY.ISYEAR.LTIME, 55900580 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) 55900590 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 55900600 

COMMON /FRCST/ ALT(30) ,DIR(30) , SPEED(30) ,TEMP(30) ,PRESS(30) , 55900610 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) 55900620 

C LAYER PARAMETERS 55900630 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , 55900640 

SIGYO(29) 55900650 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) 55900660 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S5900670 

C CALCULATED NEW LAYER PARAMETERS S5900680 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,55900690 
SPEEDN(32) 55900700 

C CONVERSION FACTORS 55900710 

COMMON /CNVRT/ QCONV(4) ,QPDEPH 55900720 

C S5900730 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S5900740 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S5900750 

C READ/WRITE BUFFER 55900760 

C A R R A Y “ 2077 + 1 + 1 + 2 * 900 = 387955900770 

C******************* **************************************************** 55 9 007 80 
C S5900790 

C EQUIVALENCE STATEMENTS S5 900800 

EQUIVALENCE(IIU,IPAR(D) , (IOU,IPAR(2)) , (IPU1,IPAR(3)) S5900810 

,(IPU2,IPAR(4)),(IPU3,IPAR(5)) S5900820 

EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) S5900830 

C S5900840 

C**** END OF COMMON AREA ****55900850 

Cq S5900860 

C 55900870 

DIMENSION UBARNK(50),PHIS(50),SIGAPK(50),SIGEPK(50) S5900880 

C S5900890 

DATA RAD/. 01745329/ S5900900 

C S5900910 

C S5900920 

C S5900930 

C S5900940 

B1 = 1.0 S5900950 

SUMX =0.0 S5900960 

SUMY = 0.0 S5900970 

SIGAL =0.0 S5900980 

SICEL =0.0 S5900990 

IF (IRUN .EQ. 4) WRITE (IOU,9001) S5901000 

DO 60 M=1,NLAYS S5901010 

PHIS(M) = 0.0 S5901020 
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DZ = ALT(M+1) - ALT(M) 

SIGAL = SIGAL + SIGAPN(M)*DZ 
SIGEL = SIGEL + SIGEPN(M)*DZ 
SIGAPK(M) = SIGAL/ALT(M+1)*RAD 
SIGEPK(M) = SIGEL/ALT(M+1)*RAD 
IF(M .LT, IBOT.AND.IFCON .NE. 0) GOTO 60 
AO = DDIR(M)*RAD 
IF (ABS(A0)-2.0E-3) 10,20,20 
10 AO = 2.0E-3*B1 
20 IF (AO ,LT. 0.0) B1 = 1.0 
IF (AO .GT. 0.0) B1 =-1.0 
UBDZ = SPEEDN(M)*DZ 
BK = AO/DZ 
A4 = UBDZ /AO 
BKS = BK*ALT(M) 

BKP = BK*(0.5*DZ+ALT(M)) 

X22 = SIN(BKS) 

Y22 = COS (BKS) 

X2 = (SIN(BKP)-X22)*A4 
Y2 = (COS(BKP)-Y22)*A4 
XNK = SUMX + X2 
YNK = SUMY + Y2 
BKP = BK*ALT(M+1) 

X2 = (SIN(BKP)-X22)*A4 
Y2 = (COS(BKP)-Y22)*A4 
SUMX = SUMX+X2 
SUMY = SUMY+Y2 
IF(YNK) 40,30,40 

30 UBARNK(M) = XNK/(ALT(M)+DZ*.5) 

GOTO 50 

40 PHIS(M) = ATAN2(YNK,XNK) 

UBARNK(M) = SQRT(XNK*XNK + YNK*YNK) / (ALT(M)+DZ*. 5) 

50 IF (IRUN .NE. 4) GO TO 60 
PHISP = PHIS (M) /RAD 

WRITE (lOU, 9002) M,A4 ,DZ,DDIR(M) ,SPEEDN(M) , XNK, YNK, PHISP, 
lUBARNK(M) 

60 CONTINUE 
RETURN 

9001 FORMAT (IHO, 12X, 1HM,7X,2HA4 , lOX, 2HDZ,8X,4HDDIR, lOX, 
*6HSPEEDN , 7X , 3HXNK , 8X , 3HYNK , 9X , 4HPHIS , 8X , 6HUBARNK) 

9002 F0RMAT(12X,I3,1X,8F12.3) 

END 


S5901030 

S5901040 

S5901050 

S5901060 

S5901070 

S5901080 

S5901090 

S5901100 

S5901110 

S5901120 

S5901130 

S5901140 

S5901150 

S5901160 

S5901170 

S5901180 

S5901190 

S5901200 

S5901210 

S5901220 

S5901230 

S5901240 

S5901250 

S5901260 

S5901270 

S5901280 

S5901290 

S5901300 

S5901310 

S5901320 

S5901330 

S5901340 

S5901350 

S5901360 

S5901370 

S5901380 

S5901390 

S5901400 

S5901410 

S5901420 

S5901430 

S5901440 
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REEDM SOURCE MODULE &RCIMM 


02 APR 82 LOCATION: KSC 


FTN4 

PROGRAM RCIMM(5,119) 

' . , UPDATE: 8213 SOURCE: 

C**A* DECLARATIONS. 

C 

CC 

C**** BEGINCOM MONAREA 

04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C— — INPUT OPTIONS 

REAL LAMBDA 

_ INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MOD EL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAI-IMAY , GAMMAZ , ALPHA , BETA , 

XRY ,XRZ , XLRY , TIMAV , ISIG , ICALC , CALHT , 
IPLACE,IPRINT,SIGMAR, SIGNER, LSITE.BOTLAY, 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN ( 2 ) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CIS0(10) ,DISO(10) , 
TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, 

MOD EL4 , MODELS , MODELS 
INTEGER RUNNUM , RT , CL , C S 

COMMON /CTRFL/ IFLG, RUNNUM, NUM,NLAYS,NBK,QC,QT, HEAT, ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

SIGZ , ISNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
.MIXING, MAXDEP, LAYBOT(3) 

,ALTSV,BATCH,CL(14) ,CS(10) , GASSET, lAGAIN, 

ICHAR (12), IDXCL , IDXCS , TERROR ( 5 ) , IFRMT ( 80 ) , 

MINUS 1,MINUS9, MINS 1.MINS9, 

M0DEL4 , MODELS , MODELS , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24) ,TPROPC,IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, 

, TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, 

. CLRLNE.INSLNE, DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2),ULINE(2), 


SSOOOOOO 

SSOOOOlO 

SS000020 

SS000030 

SS000040 

SS000050 

****ssooooso 

SS000070 
SS000080 
S6000090 
SSOOOlOO 
S6000110 
S6000120 
SS000130 
SS000140 
S60001SO 
SSOOOISO 
SS000170 
SSOOOISO 
SS000190 
SS000200 
SS000210 
SS000220 
SS000230 
SS000240 
SS0002S0 
SS0002S0 
SS000270 
SS000280 
SS000290 
SS000300 
SS000310 
SS000320 
S6000330 
SS000340 
SS0003S0 
SS0003S0 
SS000370 
SS000380 
SS000390 
SS000400 


TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , SS0004 1 0 


CLRLNE , INSLNE , DELINE , 

IESCAJ(3) .NULL.IBLNK, 

IPAR(S),ICU,IYSJ,IYESJ,INJ.INOJ,NAMEP(3) 

C : VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 

C time PARAMETERS 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, 
. LDAY,LYEAR,ISMON(2) , JMON(2) ,LMON(2) ,LSDT(2) 


SS000420 

SS000430 

SS000440 

SS0004S0 

SS0004SO 

SS000470 

SS000480 

SS000490 
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c SOUNDING/ FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S6000500 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S6000510 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S6000520 

C LAYER PARAMETERS S6000530 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S6000540 

• SIGYO(29) S6000550 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S6000560 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S6000570 

C CALCULATED NEW LAYER PARAMETERS S6000580 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) , S6000590 

• SPEEDN(32) S6000600 

C CONVERSION FACTORS S6000610 

COMMON /CNVRT/ QCONV(4) .QPDEPH S6000620 

^ S6000630 


C**********C0MM0N buffer ARRAY FOR COMMON MODIFICATION******************S6000640 
COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S6000650 

■READ/TOITE BUFFER S6000660 

■ARRAY = 2077 +1 + 1 + 2 * 900 = 3879S6000670 


c 

c 



DATA JVERSN/8213/ 

S6000690 

S6000700 


CALL RMPAR(IFR>[T) 

S6000710 

S6000720 


IF (IVERSN ,NE. JVERSN) CALL LOADS (-1,0, 0,0,0, BATCH) 

S6000730 


IF (IPAR(l) .EQ. 99) GO TO 30 

S6000740 


JER = 0 

S6000750 


GO TO (10,50) ,IFRMT(3) 

S6000760 

10 

WRITE (ICU,9001) IPAR(4) ,INV,OFF,ULINE,OFF 

S6000770 


INPTl = IBLNK 

S6000780 


READ (ICU.9002) INPTl 

S6000790 


WRITE (ICU.9002) lESCAJ.IESCAJ 

S6000800 


IF (INPTl .NE. MINUS 1) GO TO 20 

S6000810 


JER = JER+1 

S6000820 


IF (JER .GT. 1) GO TO 60 

S6000830 


WRITE (ICU,9003) 

S6000840 


GO TO 10 

S6000850 

20 

IF (INPTl .EQ. MINUS9) GO TO 70 

S6000860 


JER = 0 

S6000870 


IF (INPTl .EQ. IHF) GO TO 30 

S6000880 


IF (INPTl .EQ. IBLNK) GO TO 40 

S6000890 


WRITE (ICU.9004) INV, OFF, 21,1 

S6000900 


GO TO 10 

S6000910 

30 

CALL RCFRM(IFRMT.CRT) 

S6000920 


IF (IPAR(l) .EQ, 99) GO TO 90 

S6000930 

40 

CALL RMCLM 

S6000940 


IF (NNNTRY .EQ. 5) GO TO 10 

S6000950 


GO TO 90 

S6000960 

50 

CALL RISOM 

S6000970 


GO TO 90 

S6000980 

60 

lERROR(l) = -1 

S6000990 


GO TO 80 

S6001000 

70 

lERROR(l) = 1 

S6001010 
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80 NNNEST = 1 
NNNTRY = 1 
90 CALL REEDM 
STOP 

9001 FORMAT (A7H MOUNT A CENTERLINE PROFILE FORM ON PLOTTER LU ,12/ 
*28X,2A2,14HSPACE - RETURN, 2A2 , 1 IH WHEN READY/ 

*28X,6HENTER , 2A2 , IHF, 2A2 , 19H TO PLOT, THE FORM:_) 

9002 FORMAT (3A2) 

9003 FORMAT (73H *** REEDM WARNING 019, -1 NOT APPLICABLE, PROG. ABORTSS6001 100 

* IF -1 TYPED AGAIN/) S6001110 

9004 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2,6H REC. S6001120 

*,I2,1H. ,11/) S6001130 

S6001140 


S6001020 

S6001030 

S6001040 

S600L050 

S6001060 

S6001070 

S6001080 

S6001090 
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no non 


SUBROUTINE RCFRM(IPASS,CRT) 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC 

INTEGER ALTSET , OFF , BLNKNG , ULINE , TAB , TAB2 , SETTAB , CLRTAB , CURSUP , 

I CURSDN , CURLFT , CLRDSP , CLRLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2) , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP 
CLRLNE , INSLNE , DELINE , 

IESCAJ(3) .NULL.IBLNK, 

IP AR ( 5 ) , I CU , lY S J , I YES J , IN J , INO J , NAMEP ( 3 ) 

LOGICAL CRT 

INTEGER SECNDS ( 3 ) , EQUAL S ( 2 ) , BKARO . BKAKO , CR 
COMPLEX XLGND(5) ,CH(2) ,TOR(2) ,T0L(2) ,BOL(2) ,HOC(2) ,SF(3) 

,PRDT(3) ,LAUNCH(2) ,RL(2) ,DFN(2) 

DIMENSION NUML(3) ,NUM(2) ,LGNDX(21) ,IBUFR(33) ,IPASS(2) 

,LEGEND(98) .METERS (2) , IREG(2) , IN(2) 

EQUIVALENCE (NUML.NUMLI) , (NUML(2) ,NUM) , (LGNDX(2) .XLGND) 

, (IREG.REG.IA) , (IREG(2) ,IB) , (IN, INI) , (IPAR(l) , IIU) 

, (LEGEND(2) ,CH) , (LEGEND(ll) .TOR) , (LEGEND(20) ,TOL) 

, (LEGEND(29) ,BOL) , (LEGEND (38) .HOC) , (LEGEND(60) ,PRDT) 

, (LEGEND(73) .LAUNCH) , (LEGEND(46) .LGNDl) , (LEGEND(59) .LGND2) 

, (LEGEND(72) .LGND3) , (LEGEND(82) ,RL) , (LEGEND(91) ,DFN) 

, (LEGEND (8 1 ) .LGND4) , (LEGEND (90) .LGND5) . (LEGEND (47) , SF) 
,(IPAR(2),IOU) 

DATA LEGEND ( 1 ) , LEGEND ( 1 0) , LEGEND (19), LEGEND ( 28 ) , LEGEND (37 ) 
,LEGEND(46) ,LEGEND(59) ,LEGEND(72) ,LEGEND(81) ,LEGEND(90) 
.LGNDX(l) 

/12, 12, 12, 15, 14. 18, 18, 12, 13, 14, 40/ 

DATA CH/8HCL0UD HE.8HIGHT /.TOR/8HTIME OF .8HRISE 
.TOL/8HTOP OF L.8HAYER / ,BOL/8HBOTTOM 0,8HF LAYER 
.HOC/8HHEIGHT 0,8HF CALC /,SF/8HSOUNDING,8H/FORECAS 
,8HT: /.PRDT/8HTIME OF , 8HEXECUTI0.8HN: / 

.LAUNCH/8HLAUNCH T.8HIME: / 

.RL/8HRUN L0CA.8HTI0N: /.DFN/8HDATA FIL,8HENAME: / 

DATA METERS/1, 1HM/,SECNDS/3,2HSE,2HC /, EQUALS/1 , 1H=/ 

DATA XLGND/8H DISTANC,8HE FROM C.8HLOUD STA,8HBILIZATI 
. ,8HON (KM) /,IN1/1H(3/ 

DATA CR,BKARO,BKAKO/15B,20137B,137B/ 

FIRST EXECUTABLE STATEMENT 

IF (CRT) GO TO 10 
CR = NULL 
BKARO = NULL 
BKAKO = IBLNK 
10 IPU2=IPASS(1) 

IN1=IAND(IPASS(2) , 177400B)+40B 
IF (IIU .EQ. 99) CALL LURQ(1 , IPU2, 1) 

20 CALL PLTLU(IPU2) 

PLOT SIZE IN CM 


/ 


/ 


S6100000 
S6100010 
S6100020 
S6100030 
S6 100040 
S6100050 
,S6100060 
S6100070 
S6100080 
S6100090 
S6100100 
S6100110 
S6100120 
S6100130 
S6100140 
S6100150 
S6100160 
S6100170 
S6100180 
S6100190 
S6100200 
S6100210 
S6100220 
S6100230 
S6100240 
S6100250 
S6100260 
S6100270 
S6100280 
S6100290 
S6100300 
S6100310 
S6100320 
S6100330 
S6100340 
S6100350 
S6100360 
S6100370 
S6100380 
S6100390 
S6100400 
S6100410 
S6100420 
S6100430 
S6100440 
S6100450 
S6100460 
S6100470 
S6100480 
S6100490 
S6100500 


256 



c 


CALL SFACT (33. 0,24.0) 

CALL LLEFT 

30 WRITE (ICU, 9001) BLNKNG , OFF , BKARO 

9001 FORMAT (1 OX, 2A2,15HFORM GENERATION, 3A2) 

C 

c MARK LOWER LEFT 

C 

CALL PLOT(0.2,0.0,2) 

CALL PLOT(0.0,0.0,2) 

CALL PLOT(0.0,0.2,2) 

C 

c PLOTTER NOW SET UP:: LABEL X-AXIS 

C 

X=2.26 
NUMLI=2 
DO 40 1=0,30 
CALL CODE 
WRITE(NUM,9002) I 

9002 F0RMAT(I2) 

CALL SYMB(X+FLOAT(I) ,1.8, 0.2, NUML, 0.0,1) 
40 CONTINUE 
C 

c DRAW X-AXIS W/TICS 

C 

CALL PLOT(32.5,2.2,3) 

CALL PLOT(32.5,2.5,2) 

DO 50 1=29, 0,-1 
FI=2.5+FLOAT(I) 

CALL PLOT (FI, 2. 5, 2) 

CALL PLOT (FI, 2. 2, 2) 

CALL PLOT(FI,2.5,2) 

50 CONTINUE 

CALL PLOT(FI,2.5,3) 

CALL SYMB (13.5,1.3,0.2, LGNDX ,0.0,1) 

C 

c BEGIN LEGEND 

C 

CALL SYMB(16.7,20.5,0.2,LGND5, 0.0,1) 
CALL SYMB (16.7,21.0,0.2, LGND4 ,0.0,1) 
CALL SYMBQ6.7,21.5,0.2,LGND3,0.0,1) 
CALL SYMB(16.7,22.0,0.2,LGND2,0.0,1) 
CALL SYMB(16.7,22.5,0.2,LGND1, 0.0,1) 

C 

C UNITS 

C 

CALL SYMB( 14. 7, 22. 5, 0.2, METERS, 0.0,1) 
CALL SYMB(14.7,22.0,0.2,SECNDS,0.0,1) 
CALL SYMB(14.7,21.5,0.2,METERS,0.0,1) 
CALL SYMB(14.7,21.0,0.2,METERS,0.0,1) 
CALL SYMB(14.7,20.5,0.2,METERS,0.0,1) 

C 


S6100510 

S6100520 

S6100530 

S6100540 

S6100550 

S6100560 

S6100570 

S6100580 

S6100590 

S6100600 

S6100610 

S6100620 

S6100630 

S6100640 

S6100650 

S6100660 

S6100670 

S6100680 

S6100690 

S6100700 

S6100710 

S6100720 

S6100730 

S6100740 

S6100750 

S6100760 

S6100770 

S6100780 

S6100790 

S6100800 

S6100810 

S6100820 

S6100830 

S6100840 

S6100850 

S6100860 

S6100870 

S6100880 

S6100890 

S6100900 

S6100910 

S6100920 

S6100930 

S6100940 

S6100950 

S6100960 

S6100970 

S6100980 

S6100990 

S6101000 

S6101010 

S6101020 
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c . EQUALS 

C 

FI=20.0 
DO 60 1=1,5 
FI=FI+0.5 

CALL SYMB(1 1.9, FI, 0.2, EQUALS, 0.0,1) 
60 CONTINUE 
C 

C MORE LEGEND 

C 

DO 70 1=1,37,9 

CALL SYMB(7.7,FI,0.2,LEGEND(I) ,0.0,1) 
FI=FI-0.5 
70 CONTINUE 
C 

C MARK UPPER RIGHT 

C 

CALL PLOT(33.0,23.8,3) 

CALL PLOT(33. 0,24. 0,2) 

CALL PLOT(32.8.24.0,2) 

CALL PLOT(33. 0,24. 0,3) 

REMOVE "FORM GENERATION" 

CALL URITE 

WRITE(ICU,9003) CR,CLRDSP,BKAKO 
FORMAT ( 5 0A2) 

CHECK FOR "F" 


S6101030 

S6101040 

S6101050 

S6101060 

S6101070 

S6101080 

S6101090 

S6101100 

S6101110 

S6101120 

S6101130 

S6101140 

S6101150 

S6101160 

S6101170 

S6101180 

S6101190 

S6101200 

S6101210 

S6101220 

S6101230 

S6101240 

S6101250 

S6101260 

S6101270 

S6101280 

S6101290 

S6101300 

S6101310 


IFdNl.EQ. IHF) GO TO 90 

80 WRITE(ICU,9004) BLNKNG,OFF,INVNDR,INV,OFF,ULINE,OFF,BKARO 

9004 FORMAT(53H DO YOU WANT TO PLOT ANOTHER CENTERLINE PROFILE FORM’ 

. /5X,2A2,30HCHANGE PLOT PAPER BEFORE A YES,2A2 

. ,14X,1H(,2A2,1HY,2A2,2HES,2A2,4H OR ,2A2, 1HN,2A2,2H0) ,A2) 

INI = IBLNK 

READ (ICU,9005) INI 

WRITE ( ICU , 9003 ) CURSUP , CURSUP . CR, CLRDSP , BKAKO 
IF(INl.EQ.IYSJ.OR.INl.EQ.IBLNK.OR.INl.EQ.IYESJ) GO TO 30 
(^Nl ^EQ. INJ.0R.INI .EQ. INOJ) GO TO 90 
WRITE (fCU,9006) INV,OFF,0,0 
GO TO 80 

9005 FORMAT (A2) 

9006 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR,2A2.6H REC 
*,I2,1H.,I1/) 

90 CONTINUE 
RETURN 
END 
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REEDM SOURCE MODULE &RC1MN 


FTN4 

SUBROUTINE RISOM S6200010 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S6200020 

C: S6200030 

C: :::::::::::::::::::::::::::::::::: :: 5 ::: 5 J 5 5 :::::::::: : S6200040 

C:;: ::: S6200050 

C::: ::: S6200060 

C::: ORGANIZATION: H. E. CRAMER CO. , INC. ::: S6200070 

C::: ::: S6200080 

C::: WORK FOR: DR. J. B. STEPHENS (ES84) ::: S6200090 

C:;: ::: S6200100 

C::: PROGRAM CODE; RISOM ::: S6200110 

C::: ::: S6200120 

C::: PROGRAM DESCRIPTION: ONE OF THE MODULES FOR ROCKET EXHAUST ::: S6 200 130 

C::: EFFLUENT DIFFUSION ANALYSIS (MULTI-LAYER) :: : S6200140 

C::; ■ ::: S6200150 

C::: INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS ::: S6200160 

C;:: ::; S6200170 

C::: OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS, PLOTS ::: S6200180 

C::: ::: S6200190 

S6200200 

Q S6200210 

C S6200220 

Q *********************************************************************86200230 
c * *86200240 

C * ISOPLETH PLOTTING PROGRAM — A PROGRAM IN THE REED SERIES *86200250 
C * OF PROGRAMS *86200260 

C * *86200270 

C *********************************************************************86200280 

C<^ S6200290 

C**** BEGIN COMMONAREA ****86200300 

C 04/02/82 S6200310 

C math PARAMETERS AND CONSTANTS S6200320 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S6200330 

C INPUT OPTIONS S6200340 

REAL LAMBDA S6200350 

INTEGER FILE, GOOD, TITLE S6200360 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S6200370 

. ISHAPE,GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S6200380 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S6200390 

IPLACE,IPRTNT,SIGMAR,STGMER,LSITE,BOTLAY, S6200400 

ZRK, DECAY, GOOD. NCIS0,NDIS0,NTIS0,F1LE(3) S6200410 

. .RAINRT, LAMBDA, TIM1,DURAT,NVS,1VERSN,L0CATN(2) S6200420 

,IPLLNT(4),GAMMAP(30),HM(2),CISO(10),DISO(10). S6200430 

TISO(10),TITLE(14),SIGPP(29),SIGLL(29),VS(20), S6200440 

. FS(20) ,MDLNAM(12) ,DBAR(20) * S6200450 

C COUNTERS , FLAGS , GENERAL AND INDEX VARIABLES S6200460 

LOGICAL I SNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S6 2004 70 

, MODEL4, MODELS, MODEL6 S6200480 

INTEGER RUNNUM,RT,CL,CS S6200490 
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COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S6200500 

DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S6200510 

SIGZ,ISNDFO,CRT,LAYTOP(3),ITDU,KEEP S6200520 

, MIXING, MAXDEP,LAYBOT(3) S6200530 

,ALTSV, BATCH, CL(14),CS(10), GASSET, lAGAIN, S6200540 

ICHAR(12),IDXCL,IDXCS,IERROR(5),IFRMT(80), S6200550 

MINUS 1,MINUS9, MINS 1,MINS9, S6200560 

MODEL4, MODELS, MOD EL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S6200570 
RT(24),TPR0PC,IDXRT S6200580 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S6200590 

INTEGER ALTS ET, OFF, BLNKNG,INV,ULINE,INVNDR, S6200600 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S6200610 

CLRLNE,INSLNE, DELINE S6200620 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S6200630 

. INVNDR(2) ,ULINE(2) , S6200640 

TAB , TAB 2 , S ETTAB , CLRTAB , CURSUP , CURSDN , CURLFT ,CLRDSP,S620065O 


. CLRLNE, INSLNE, DELINE, S6200660 

. IESCAJ(3) ,NULL,IBLNK, S6200670 

IPAR(5),ICU,IYSJ,IYESJ,INJ,INOJ,NAMEP(3) S6200680 

C VEHICLE PARAMETERS S6200690 

COMMON /VCLPR/ VPAR(17) S6 2007 00 

C time parameters S6200710 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S6200720 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S6200730 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S6200740 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S6200750 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S6200760 

C LAYER PARAMETERS S6200770 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S6200780 

SIGYO(29) S6200790 

C CALCULATED BOUNDRY DATA (FOR NEl^ LAYERS) S6 200800 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) S6200810 

C CALCULATED NEW LAYER PARAMETERS S6 2008 20 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) ,S6200830 
SPEEDN(32) S6200840 

C CONVERSION FACTORS S6200850 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S6200860 

C S6200870 

C**********C0MM0N BUFFER ARRAY FOR COMMON MODIFICATION******************S6200880 

COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S6200890 

C READ/WRITE BUFFER S6200900 

C A R R A Y = 2077 + 1 + 1 + 2 * 900 = 3879S6200910 

C ' S6200930 

C EQUIVALENCE STATEMENTS S6 200940 

EQUIVALENCE (IPUl , IPAR(3) ) S6200950 

,(IPU2,IPAR(4)),(IPU3,IPAR(5)) S6200960 

EQUIVALENCE (MAXDEP,GRVSET) , (IFRMT(l) .IFRMTl) S6200970 

C S6200980 

C**** . ENDOFCOMMONAREA ****S6200990 

CC S6201000 

C S6201010 
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n n o 


INTEGER ZIP.FIRSTV 

DIMENSION RANGE (30,6) , BEARNG (30 , 6 ) , SIGYBR (30 , 6) , CORSG (30 , 6) 
. ,XCORSG(6),ZIP(5),MTH(4,8),NFSLS(3,9) 

LOGICAL TMOUT.TO.FIRSTP 
COMPLEX RBORSG(6) 

EQUIVALENCE STATEMENTS 


EQUIVALENCE 

. (PLUS, RANGE) , (PLUS(181) , BEARNG) , (PLUS (361) .SIGYBR) 

. ,(PLUS(541),XC0RSG),(PLUS(547), CORSG), (PLUS(727),RBORSG) _ 


C 

CF OUTPUT FORMAT STATEMENTS 

CF 

9001 FORMAT(I4,2A2,I3, 1X,A2,A1, 1X,I4) 

9002 FORMAT (A1,2H -,G10.4) 


TYPE AND DIMENSION STATEMENTS 


C** 

C** 

c 


c 

c 

c 


c 

c 

c 


VARIABLE NAME "PLUS" WAS CHANGED NOV 9, 1979 BECAUSE OF CONFLICT 
WITH THE LABLED COMMON DEVICE EMPLOYED. . .J.S.H. 

LOGICAL DFALTC , FLGEND , FLGDAT , FLGLTR, TTY , FLGOUT , FLGSPC (4) , TWOLAY 
FLGPH 

* INTEGER PEN , UNIT S ( 7 , 7 ) , PDO , DFLT , WNITS ( 6 , 7 ) . AT ( 2 ) , ADD ( 2 ) , LETR2 ( 2 ) 

, LALPHA ( 2 ) , BKARO , BLANK 1 , BKAKO ,YORNO(18),CDT(57), SMORLW (14) 
, CR , CRLF , CURSUP , BLANK , RS , PSORL ( 9 , 4 ) 

DIMENSION PLETH(IO) ,LPAREN(2) , JSPECI(3,4) ,LSPECI(11 ,4) 

,IALPHA(80) ,KSPECI(3,4) ,IP(5) ,L1(3) 

,DISOF(5) ,LPLNTQ(1) , JCDT(12,6) 

,KCDT(13,6) ,DPLETH(5) ,KSPL(4) ,KCDTN(6) 

,JUNITS(6,4) , JLABS(6,4) , JDATA(6,4) ,LETRO(2) 

,IBREAK(5),IFISOS(10),NOISOS(13),IBUF(4) 

EQUIVALENCE (LETR2 (2) ,LETR) , (LALPHA ( 2) , I ALPHA) , (LALPHA,LALPH1) 
,(L1(2),L3) 

,(IALPHA(1),IFRMT(D) 

JUNITS (CHOICE , SPECIES) 

DATA JUNITS 

/I, 3, 1,5, 0,0 
.1,3, 1,0, 0,0 
,1.3. 1,0, 0,0 
,2, 4, 2, 6, 6, 7/ 

DATA N0IS0S/23,1H-,2H0U,2HTS.2HTD.1HE,2HPL,2H0T,2H B.2H0U,2HND, 
2HAR.1HY/ 

JLABS (CHOICE , SPECIES) 


DATA JLABS 


/ 1 , 2 , 3 , 4 , 0,0 
, 1 , 2 , 3 , 0 . 0,0 
, 1 , 2 , 3 , 0 , 0,0 
, 1 , 2 , 3 , 5 , 6 , 6 / 


S6201020 

S6201030 

S6201040 

S6201050 

S6201060 

S6201070 

S6201080 

S6201090 

S6201100 

S6201110 

S6201120 

S6201130 

S6201140 

S6201150 

S6201160 

S6201170 

S6201180 

S6201190 

S6201200 

S6201210 

S6201220 

S6201230 

S6201240 

S6201250 

S6201260 

S6201270 

S6201280 

S6201290 

S6201300 

S6201310 

S6201320 

S6201330 

S6201340 

S6201350 

S6201360 

S6201370 

S6201380 

S6201390 

S6201400 

S6201410 

S6201420 

S6201430 

S6201440 

S6201450 

S6201460 

S6201470 

S6201480 

S6201490 

S6201500 

S6201510 

S6201520 

S6201530 
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Cl cy Ci o n o 


JDATACCHOICE, SPECIES) 
DATA JDATA 

/I, 2, 3, 1,0,0 
, 1 , 2 , 3 , 0 , 0,0 
, 1 , 2 , 3 , 0 , 0,0 
,4,5,6,4,4,17 


UNITS 


C 

C 

C 


DATA UNITS 

/3*0B,2H p,2Hpm,2*0B 
,3*0B,2H m,2Hg/,46416B,31417B 

* ,0B,2H p,2Hpm,2H-s,2Hec,2*0B 

,0B,2H m,2Hg-,2Hse,2Hc/.46416B,31417B 
. ,3*0B,40B,2HpH,2*0B 

,2*0B,2H m,2Hg/,46416B,31017B,0B 
,40B,2HPA,2HRT,2H./,46416B,31017B.OB/ 

DATA UNITS 

/2H P,2HPM,4*2H 
,2H M,2HG/,2HM*,2H*3,2*2H 
,2H P,2HPM,2H-S,2HEC,2*2H 
,2H M,2HG-,2HSE,2HC/,2HM*,2H*3’ 

,2H P.2HH ,4*2H 

,2H M,2HG/,2HM*,2H*2,2*2H 

* ,2H P,2HAR,2HT. ,2H/M,2H**,2H2 / 

DATA MTH/2H T, 2HHI , 2HRD, 2H 

,2H F,2HOU,2HRT,2HH 
,2H F,2HIF,2HTH,2H 
,2H S,2HIX,2HTH,2H 
,2HSE,2HVE,2HNT,2HH 
,2H E,2HIG,2HHT,2HH 
,2H N,2HIN,2HTH,2H 
,2H ,2HLA,2HST,2H / 

DATA NFSLS/2HSE,2HCO,2HND, 

* 2HTH,2HIR,1HD, 

* 2HFO,2HUR,2HTH, 

* 2HFI,2HFT,1HH, 

* 2HSI,2HXT,1HH, 

* 2HSE,2HVE,2HNT, 

* 2HEI,2HGH,2HTH, 

* 2HNI.2HNT.1HH, 

* 2HTE.2HNT.1HH/ 

VARIABLES 


DATA JCDT 
. 75*2H 
. ,9*2H 

. ,2H T.2HIM.2HE 
. ,8*2H 


, 2H C , 2H0N , 2HCE , 2HNT , 2HRA . 2HTI , 2H0N 

,2HD0,2HSA,2HGE 

, 2HME , 2HAN , 2H C , 2H0N , 2HCE , 2HNT , 2HRA , 2HTI , 2H0N 

,2H A,2HCI,2HDI,2HTY 


S6201540 

S6201550 

S6201560 

S6201570 

S6201580 

S6201590 

S6201600 

S6201610 

S6201620 

S6201630 

S6201640 

S6201650 

S6201660 

S6201670 

S6201680 

S6201690 

S6201700 

S6201710 

S6201720 

S6201730 

S6201740 

S6201750 

S6201760 

S6201770 

S6201780 

S6201790 

S6201800 

S6201810 

S6201820 

S6201830 

S6201840 

S6201850 

S6201860 

S6201870 

S6201880 

S6201890 

S6201900 

S6201910 

S6201920 

S6201930 

S6201940 

S6201950 

S6201960 

S6201970 

S6201980 

S6201990 

S6202000 

S6202010 

S6202020 

S6202030 

S6202040 

S6202050 
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non 


. ,3*2H ,2HWA,2HSH,2HOU, 

. ,2HGR,2HAV,2HIT,2HAT,2HIO,2HNA, 
DATA KCDT 

. /2H C,2HON,2HCE,2HNT,2HRA,2HTI, 
. ,2H D,2HOS,2HAG,2HE ,9*0B 
. ,2H T,2HIM,2HE , 2HME , 2HAN , 2H C, 
. ,2H A,2HCI,2HDI,2HTY,40B,8*0B 
. ,2H W,2HAS,2HHO,2HUT,2H D.2HEP, 
. ,2H G,2HRA,2HVI,2HTA,2HTI,2H0N, 
. ,2HN / 

DATA CDT 

. /40B.15446B,62104B,103B,15446B, 
. ,2HON,5*0B,15446B,62100B 
. ,40B, 15446B.62104B, 104B, 15446B, 
. ,62100B 

. ,40B,15446B,62104B,124B,15446B, 
. ,2HON,2HCE,2HNT,2HRA,2HTI,2HON, 

SPECIES 


2HT ,2HDE,2HPO,2HSI,2HTI,2HON 
2HL ,2HDE,2HPO,2HSI,2HTI,2HON/ 

2HON,40B,5*0B 

2H0N , 2HCE , 2HNT , 2HRA , 2HTI , 2H0N , 4 OB 

2HOS.2HIT.2HIO,2HN ,3*0B 
2HAL,2H D,2HEP,2HOS,2HIT,2HIO 

62 lOOB , 2HON , 2HCE , 2HNT , 2HRA , 2HTI 

6210OB,2HOS,2HAG,105B,8*0B, 15446B 

62100B,2pM,2HE , 2HME , 2HAN , 2H C 
15446B.62100B/ 


DATA JSPECI 
. /2H ,2H H,2HC1 

, ,2H ,2H C,2H02 

. ,2H ,2H ,2HC0 

, ,2H A,2H12,2H03/ 

DATA LSPECI 

. /15446B,62104B,110B,15446B.62100B,2HC1,15446B,62100B,OB,15446B 

. ,62100b 

. ,15446B,62104B,103B,15446B,62100B,117B,15446B,62104B,62B,15446B 

. .62100B 

. ,15446B.62104B,103B,15446B,62100B,117B,15446B,62100B,OB,15446B 

. ,62100b 

. ,15446b, 62104B,101B,15446B,62100B,2H12,15446B,62100B,2H03,15446B 

. ,62100B/ ' ■ 

DATA KSPECI 
. /2H H,2HCL,40B 
. ,2H C,2H02,40B 
. ,2H C,2HO ,0B 
. ,2H A,2HL2,2H03/ 

DATA KSPL/4,4,3,6/,FLGSPC/4*.FAISE./,PXGPH/.FALSE./ 

. ,KCDTN/14,7,24,8,19,25/ 

DATA CR , CRLF , BLANK , BLANK 1 , BKARO , BKAKO , ZIP 
/15B, 64 12B,20040B,40B,20137B, 1378,5*0/ 

DATA AT,ADD,LETR2(1) ,LPAREN,BKARO/l,lH(a,l,lH+,l,2H( ,2H ),2H_/ 

. ,LETRO/l ,1H0/ 

DATA DISOF/0.1,0.3,0.5,0.7,0.9/ 

DATA SM0RLW/2H L,2H0W,2HER 
,2H ,2H S.2HUM 

. ,2H L,2HAY,2HER,2H 1 

. ,2H L,2HAY,2HER,2H 2/ 

DATA PSORL/16,2HLO,2HWE,2HR ,2HLA,2HYE,2HR ,2HON,2HLY 
. ,13,2HSU,2HM ,2HOF,2H L,2HAY,2HER,2HS ,2H 


S6202060 

S6202070 

S6202080 

S6202090 

S6202100 

S6202110 

S6202120 

S6202130 

S6202140 

S6202150 

S6202160 

S6202170 

S6202180 

S6202190 

S6202200 

S6202210 

S6202220 

S6202230 

S6202240 

S6202250 

S6202260 

S6202270 

S6202280 

S6202290 

S6202300 

S6202310 

S6202320 

S6202330 

S6202340 

S6202350 

S6202360 

S6202370 

S6202380 

S6202390 

S6202400 

S6202410 

S6202420 

S6202430 

S6202440 

S6202450 

S6202460 

S6202470 

S6202480 

S6202490 

S6202500 

S6202510 

S6202520 

S6202530 

S6202540 

S6202550 

S6202560 

S6202570 
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noon 


c 

c 

c 


c 

c**** 

c 


,12,2HLA,2HYE,2HR ,2H1 ,2HON,2HLY,2H ,2H 
,12,2HLA,2HYE,2HR ,2H2 ,2HON,2HLY,2H ,2H / 

DATA XSCALE.YSCALE,D2RAD/0. 2631, 0.3545, 0.01745329/ 

DATA YORNO/15446B,62106B, 131B, 15446B,62102B,2HES,15446B,62100B 
. ,2H 0,2HR ,15446B,62104B,116B,15446B,62100B,117B,15446B,62100B/ 
DATA ICOMMA/26000B/ 

DATA IIHLl , IHl , IIHL2 , IH2 , IIHLA, IIHRl , IIHR2/2HL1 , IHl , 2HL2 , 1H2 , 2HLA 
2HR1.2HR2/ 

, IIHSU/2HSU/ , IHC , IHD , IHT , IHM, IHP , IHL, THAT, IHV/ IHC , IHD , IHT , IHM 
1HP,1HL,1H@,1HV/,IHS/1HS/ 

STATEMENT FUNCTIONS 

XRF(I)=(RISTIM(I)-RISB0T)*SPEEDN(I)*COS((360.0-DIRN(I))*D2RAD) 

YRF(I)=(RISTIM(I)-RISBOT)*SPEEDN(I)*SIN((360.0-DIRN(I))*D2RAD) 

XRP (R, B) =R*C0S ( ( 180 . 0-B) *D2RAD) 

YPvP(R,B)=R*SIN(^80.0-B)*D2RAD) 


FIRST EXECUTABLE STATEMENT. 

TTY=.NOT.CRT 
IF(CRT) GO TO 50 
K=0 

DO 40 1=1,6 
IF(I.GT.4) GO TO 30 
DO 20 J=l,4 

LSPECI(3*I-2,J) = NULL 
LSPECI (3*1-1, J) = NULL 
IF(J.GT.3) GO TO 20 
IF(I.GT.2) GO TO 10 
CDT(3*I-1+19*(J-1)) = NULL 
CDT(3*I+19*(J-1)) = NULL 
GO TO 20 

10 CDT(18+19*(J-1)) = NULL 
CDTn9+19*(J-l)) = NULL 
20 CONTINUE 

IF(I.EQ.4) K=1 
30 YORNO(3*I+K-2) = NULL 
YORNO(3*I+K-l) = NULL 
40 CONTINUE 
50 ASSIGN 80 TO IGO 
FIRSTP=. FALSE. 

FIRSTV=-1 

SET TABS AND DEFINE ALTERNATE CHARACTER SET. 

TABS SET IN COLS: 7,20,30,49,64 

IF (CRT) WRITE (ICU, 9003) CR.CLRDSP, (SETTAB, 1=1,5) ,ALTSET,CR,BKAKO 
9003 FORMAT (2 A2 , 6X , A2 , 1 3X , A2 , 1 OX , A2 , 1 9X , A2 , 1 5X , 5 A2 ) 

IPLTHP=0 
60 IVARP =0 


S6202580 
S6202590 
S6202600 
S6202610 
S6202620 
S6202630 
,56202640 
S6202650 
,56202660 
S6202670 
S6202680 
S6202690 
S6202700 
S6202710 . 
S6202720 
S6202730 
S6202740 
S6202750 
S6202760 
S6202770 
S6202780 
S6202790 
S6202800 
S6202810 
S6202820 
S6202830 
S6202840 
S6202850 
S6202860 
S6202870 
S6202880 
S6202890 
S6202900 
S6202910 
S6202920 
S6202930 
S6202940 
S6202950 
S6202960 
S6202970 
S6202980 
S6202990 
S6203000 
S6203010 
S6203020 
S6203030 
S6203040 
S6203050 
S6203060 
S6203070 
S6203080 
S6203090 


264 



c DETERMINE THE ORIGIN ON THE MAP FOR THIS PLOT AND MOVE THE 

C PEN THERE 

C 

70 CONTINUE 
GO TO IGO 
C 

C SELECT VARIABLES AND POLLUTANTS TO BE PLOTTED, 

C 

80 FIRSTP=. FALSE. 

IF (MODEL. GT. 4) GO TO 220 
C 

C MODEL 4 ONLY. 

C 

LDO=l 

DO 90 J=0,2 

J19=19*J 

DO 90 1=1,19 

IALPHA(I+J19)=CDT(I+J19) 

90 CONTINUE 
C 

c INVERSE VIDEO INDICATES THE DEFAULT 

C 

IALPHA(3+19*IPLTHP)=IOR(IALPHA(3+19*IPLTHP) ,2B) 
IALPHA(6+19*IPLTHP)=I0RUALPHA(6+19*IPLTHP) ,2B) 

100 IF (CRT) GO TO 140 

IF (IPLTHP .EQ. 2) GO TO 120 
IF (IPLTHP .EQ. 1) GO TO 110 
J1 = 4 
J2 = 17 
J3 = 23 
J4 = 36 
J5 = 42 
J6 = 55 
GO TO 130 
110 J1 = 23 
J2 = 36 
J3 = 4 
J4 = 17 
J5 = 42 
J6 = 55 
GO TO 130 
120 J1 = 42 
J2 = 55 
J3 = 4 
J4 = 17 
J5 = 23 
J6 = 36 
130 CONTINUE 

WRITE(ICU,9005) LPAREN(l) , (lALPHA(I) ,I=J1 ,J2) .ICOMMA 
, (lALPHA(I) ,I=J3,J4) .ICOMMA 
. (lALPHA(I) ,I=J5, J6) ,LPAREN(2) ,BKARO 

GO TO 150 


S6203100 

S6203110 

S6203120 

S6203130 

S6203140 

S6203150 

S6203160 

S6203170 

S6203180 

S6203190 

S6203200 

S6203210 

S6203220 

S6203230 

S6203240 

S6203250 

S6203260 

S6203270 

S6203280 

S6203290 

S6203300 

S6203310 

S6203320 

S6203330 

S6203340 

S6203350 

S6203360 

S6203370 

S6203380 

S6203390 

S6203400 

S6203410 

S6203420 

S6203430 

S6203440 

S6203450 

S6203460 

S6203470 

S6203480 

S6203490 

S6203500 

S6203510 

S6203520 

S6203530 

S6203540 

S6203550 

S6203560 

S6203570 

S6203580 

S6203590 

S6203600 

S6203610 
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140 CONTINUE 

WRITE(ICU,9004) LPAREN(l) , (lALPHA(I) , 1=1 , 19) ,TAB2 
. , (lALPHA(I) ,1=20,38) ,TAB2, (lALPHA(I) ,1=39,57) 

. ,LPAREN(2) ,BKAR0 
150 CONTINUE 

9004 F0RMAT(19H PLOT ISOPLETHS OF: ,20A2/A2,2X, 19A2/A2,2X,21A2) 

9005 FORMAT(19H PLOT ISOPLETHS OF: ,47A2) 

L1=40B 

160 CALL EXEC(1,ICU+400B,L1,-1) 

C 

c 

IF(CRT) WRITE(ICU,9009) (CURSUP,K=1 ,3) .DELINE, CLRDSP,BKAK0 
IF(Ll.NE.IBLNK) GO TO 170 
C 

C DEFAULT 

C 

JDO=IPLTHP+l 
GO TO 200 

170 IF(Ll.NE.IHC) GO TO 180 
C 

C CONCENTRATION SELECTED 

C 

JDO=l 
GO TO 200 

180 IF(Ll.NE.IHD) GO TO 190 
C 

C DOSAGE SELECTED 

C 

JDO=2 
GO TO 200 

190 IF(Ll.NE.IHT) GO TO 100 
C 

C TIME MEAN CONCENTRATION 

C 

JDO=3 

200 IPLTHP=M0D(JD0,3) 

FIRSTP=. FALSE. 

JLAB=JLABS(JDO,l) 

210 WRITE(ICU,9006) (JCDT(I, JLAB) , 1=1 . 12) 

9006 FORMAT(20H PLOT ISOPLETHS OF: ,21X,12A2) 

220 IF(MODEL.GT.5) GO TO 410 
C 

C MODELS 4 AND 5 

C 

IF(FIRSTP.AND.IVARP.EQ.FIRSTV) GO TO 80 
C 

C FORM PROMPT MESSAGE (ALSO COUNT* NUMBER OF SPECIES PRESENT) 

NSPECI=0 

NWDS=0 

DO 240 J=l,4 

IF(IPLLNT(J) .LE.O) GO TO 250 


S6203620 

S6203630 

S6203640 

S6203650 

S6203660 

S6203670 

S6203680 

S6203690 

S6203700 

S6203710 

S6203720 

S6203730 

S6203740 

S6203750 

S6203760 

S6203770 

S6203780 

S6203790 

S6203800 

S6203810 

S6203820 

S6203830 

S6203840 

S6203850 

S6203860 

S6203870 

S6203880 

S6203890 

S6203900 

S6203910 

S6203920 

S6203930 

S6203940 

S6203950 

S6203960 

S6203970 

S6203980 

S6203990 

S6204000 

S6204010 

S6204020 

S6204030 

S6204040 

S6204050 

S6204060 

S6204070 

S6204080 

S6204090 

S6204100 

S6204110 

S6204120 

S6204130 
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230 

240 

250 


260 

270 

9007 


9008 


9009 


280 


290 


300 


NO DEPOSITION OR WASHOUT OF CO OR C02 

IF (MODEL . GT . 4 . AND . ( IPLLNT ( J) . EQ . 2 . OR. IPLLNT ( J) . EQ 

NWDS=NWDS+12 

NSPECI=NSPECI+1 

FLGSPC ( IPLLNT ( J ) ) = . TRUE . 

DO 230 1=1,11 

IALPHA(I+12*JM1)=LSPECI(I,IPLLNT(J)) 

CONTINUE 

I ALPHA ( 1 2 * J ) = I C OMMA 
CONTINUE 
NWDS=N1JDS- 1 

DON’T DISPLAY PROMPT IF THERE ARE NO CHOICES 
IF(NSPECI.EQ. 1) GO TO 280 
INVERSE VIDEO FOR DEFAULT 
DO 260 J=2,8,3 

I ALPHA ( J+ 1 2 * IVARP ) = I OR ( I ALPHA ( J+ 1 2* IVARP ) , 2B) 
CONTINUE 

WRITE(ICU,9007) CR,LPAREN(1) , (lALPHA(I) ,1=1 ,NWDS) 
FORMAT(A2,22H PLOT ISOPLETHS FOR: ,60A2) 

LI = NULL 
L2 = NULL 
L3 = NULL 

CALL EXEC (1,ICU+400B,L 1,3) 

IF (LI .EQ. MINUS 1. AND. MODEL .LE. 4) GO TO 80 
FORMAT (5 Al) 

L2=IAND(377B,L1) 

L1=IAND(177400B,L1) 

ERASE PROMPT 

IF(CRT) WRITE(ICU,9009) CURSUP , DELINE , BKAKO 
FORMAT (50A2) 

IF(L1.NE.20000B) GO TO 290 
DEFAULT 

IDO= IPLLNT (IVARP+1) 

GO TO 390 

IF(L1.NE.44000B.OR. .NOT.FLGSPC(l)) GO TO 300 

HCL SELECTED 

ID0=1 
GO TO 380 

IF(L1.NE.40400B.OR. .N0T.FLGSPC(4)) GO TO 310 


S6204140 

S6204150 

S6204160 

,3)) GO TO 240 S6204170 

S6204180 
S6204190 
S6204200 
S6204210 
S6204220 
S6204230 
S6204240 
S6204250 
S6204260 
S6204270 
S6204280 
S6204290 
S6204300 
S6204310 
S6204320 
S6204330 
S6204340 
S6204350 
S6204360 
S6204370 

,LPAREN(2) ,BKARO S6204380 
S6204390 
S6204400 
S6204410 
S6204420 
S6204430 
S6204440 
S6204450 
S6204460 
S6204470 
S6204480 
S6204490 
S6204500 
S6204510 
S6204520 
S6204530 
S6204540 
S6204550 
S6204560 
S6204570 
S6204580 
S6204590 
S6204600 
S6204610 
S6204620 
S6204630 
S6204640 
S6204650 
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CJ 

C AL203 SELECTED 

C 

ID0=4 
GO TO 380 

310 IF(L1.EQ.41400B.AND. (FLGSPC(2).OR.FLGSPC(3))) GO TO 330 
C 

C BAD ENTRY PROCESSING 

C 

320 raiTE (ICU,9010) INV,OFF,22,2 

9010 FORMAT {2A2.38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2.6H REC 
*,I2,1H.,I2//) 

GO TO 270 
C 

C C02 AND CO 

C 

330 IF(L2.NE.62B.OR. .N0T.FLGSPC(2)) GO TO 350 
C 

C C02 SELECTED 

C 

340 ID0=2 

GO TO 380 

350 IF(L2.NE.40B.OR. .N0T.FLGSPC(3)) GO TO 37Q 
C 

C CO SELECTED 

C 

360 ID0=3 

GO TO 380 

370 IF(L2.NE.117B) GO TO 320 

IF(L3.EQ.IBLNK.AND.FLGSPC(3)) GO TO 360 
IF(L3.EQ.IH2.AND.FLGSPC(2)) GO TO 340 
GO TO 320 
C 

C PICK UP CONVERSION FACTOR AND WRITE SPECIES SELECTED 

C 

380 FIRSTP=. FALSE. 

C 

C SET UP NEXT DEFAULT 

C 

390 DO 400 1=1,4 

IF(IDO.NE.IPLLNTd)) GO TO 400 
IVARP=MOD(I,NSPECI) 

IF(FIRSTP) GO TO 410 

firstp=.true’ 

FIRSTV=MOD ( I+NSPECI- 1 , NSPECI) 

GO TO 410 
400 CONTINUE 
IVARP=0 
FIRSTP=. FALSE. 

FTRSTV=-1 
410 LNDX=0 

IF(MODEL.EQ.6) IDO=4 


S6204660 

S6204670 

S6204680 

S6204690 

S6204700 

S6204710 

S6204720 

S6204730 

S6204740 

S6204750 

S6204760 

S6204770 

S6204780 

S6204790 

S6204800 

S6204810 

S6204820 

S6204830 

S6204840 

S6204850 

S6204860 

S6204870 

S6204880 

S6204890 

S6204900 

S6204910 

S6204920 

S6204930 

S6204940 

S6204950 

S6204960 

S6204970 

S6204980 

S6204990 

S6205000 

S6205010 

S6205020 

S6205030 

S6205040 

S6205050 

S6205060 

S6205070 

S6205080 

S6205090 

S6205100 

S6205110 

S6205120 

S6205130 

S6205140 

S6205150 

S6205160 

S6205170 
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WRITE (ICU, 9007) CR, (BLANK, 1= 1 , 18) .BLANKl , (JSPECI(I.IDO) ,1=1,3) S6 205 180 
• ’iV.. IF(MODEL.LT.5) GO TO 540 S6205190 

IF (MOD EL. GT. 5) GO TO 500 S6205200 

S6205210 

MODEL 5 ONLY S6205220 

S6205230 

jD0=4 S6205240 

S6205250 

S6205260 

420 WRITE(ICU,9011) INVNDR,INV,OFF, (ULINE,OFF,I=l,4) S6205270 

9011 FORMAT(20H PLOT ISOPLETHS FOR , 2A2, IHS , 2A2 , 2HUM, 2A2, 14H OF LAYERS S6205280 
*OR ,2A2,1HL,2A2,5HAYER ,2A2, 1H1,2A2,4H OR ,2A2,1HL,2A2,5HAYER ,2A2S6205290 

*,1H2,2A2,4H? : ) S6205300 

LDO=l S6205310 

- KS = 4 S6205320 

K=4 S6205330 

:j=6 S6205340 

LNDX = 2 S6205350 

DO 430 1=1,4 S6205360 

430 IBUF(I) = IBLNK S6205370 

READ (ICU, 9009) IBUF S6205380 

IF (IBUF(l) .EQ. MINUSl) GO TO 80 S6205390 

' IF UBUFO) .NE. MINUS9) GO TO 440 S6205400 

' lERROR(l) = 1 S6205410 

« NNNEST = 1 S6 205420 

- GO TO 1280 S6205430 

440 IF (IBUF(l).EQ. IBLNK. OR. IBUF(1).EQ. IHS. OR.IBUF(l).EQ.IIHSU) GO TO S6205440 


S6205450 

S6205460 

S6205470 

S6205480 

S6205490 

S6205500 

S6205510 

S6205520 

S6205530 

S6205540 

S6205550 

S6205560 

S6205570 

S6205580 

S6205590 

S6205600 

S6205610 

S6205620 

S6205630 

S6205640 

S6205650 

S6205660 

S6205670 

S6205680 

S6205690 


, *490 

IF (IBUF(1).EQ.IIHL1.0R.IBUF(1).EQ.IH1) GO TO 460 

,:r IF (IBUF(1).EQ.IIHL2.0R.IBUF(1).EQ.IH2) GO TO 470 

IF hBUF(l).NE.IIHLA.OR.IBUF(2).NE.IYESJ) GO TO 450 
IF hBUF(3).EQ.IIHR1.0R.IBUF(4).EQ.IHl) GO TO 460 

IF (IBUFO).EQ.IIHR2.0R.IBUF(4).EQ.IH2) GO TO 470 

'450 WRITE (ICU, 9010) INV,OFF,22,3 
GO TO 420 
460 KS = 6 
K - 7 
J = 10 
LNDX = 0 
GO TO 490 

470 IF (LAYTOP(2) .GT. 0) GO TO 480 

■ IF (CRT) WRITE (ICU, 9009) CURSUP.DELINE.BKAKO 
WRITE (ICU, 90 12) 

9012 FORMAT (29H THERE IS NOT A SECOND LAYER ) 

GO TO 420 
480 KS = 8 
K = 11 
J = 14 
LNDX = 1 
•490 CONTINUE 

IF(CRT) WRITE(ICU,9009) CURSUP, DELINE, BKAKO 
WRITE (ICU, 9015) TAB2, (SMORLW(I) ,I=K,J) 
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c 

c 

c 


500 


9013 


510 

520 

9014 


530 


9015 


C 

C 

C 


540 


C 

C 

C 


550 


C 

C 


FLGPH=.TRUE. 

IF(ID0.EQ.4) FLGPH=. FALSE. 

GO TO 540 

MODEL 6 ONLY. 

IDO=4 

JDO=5 

LNDX=0 

LD0=1 

TOITE(ICU,9013) INVNDR,INV,OFF,ULINE,OFF,BKARO 
F0RMAT(21H PLOT DEPOSITION IN (,2A2, 1HM,2A2,9HILLIGRAMS,2A2,4H 
. ,2A2,1HP,2A2,14HARTICLES/M**3),A2) 

K = 40B 

CALL EXEC(1,ICU+400B,K,-1) 

IF(CRT) WRITE(ICU,9009) CURSUP, DELINE, BKAKO 

IF(K.EQ.IBLNK.OR.K.EQ.IHM) GO TO 520 

IF(K.EQ.IHP) GO TO 510 

WRITE (ICU,9010) INV,OFF,22,4 

GO TO 500 

JDO=6 

WRITE ( ICU , 90 1 4 ) INVNDR , INV , OFF , ULINE , OFF , BKARO 
FORMAT(20H PLOT ISOPLETHS FOR ,2A2 , IHS, 2A2,2HUM,2A2 , 

, 18H OF LAYERS OR FOR ,2A2, 1HL.2A2, 16HOWBR LAYER ONLY?,A2) 

K=40B 

CALL EXEC(1,ICU+400B,K,-1) 

IF(CRT) WRITE(ICU,9009) CURSUP, DELINE, BKAKO 
IF(K.EQ.IHL.OR. K.EQ.IHS.OR. K.EQ.IBLNK) GO TO 530 
WRITE (ICU, 9010) INV,OFF,22,5 
GO TO 520 
KS=4 

IF(K.EQ.IHL) KS=1 

WRITE(ICU,9015) TAB2,(SM0RLW(l),I=KS,KS+2) 

FORMAT(21H ISOPLETHS DRAWN FOR: ,A2, 11X,4A2) 

IF(K.NE.IHL) GO TO 540 
LNDX=1 

SELECT UNITS FOR DISPLAY AND DATA LOCATION 

JUNIT=JUNITS ( JDO , IDO) 

JLAB=JLABS(JDO,IDO) 

LNDX=LNDX+ JDATA (JDO , IDO) 

RESET YORNO DEFAULT BACK TO Y 

IF (TTY) GO TO 560 
YORNO( 2)=62106B 
YORNO( 5)=62102B 
YORNO(12)=62104B 
YORNO (15)=62100B 

COMPUTE AND DISPLAY MAXIMUM 


S6205700 
S6205710 
S6205720 
S6205730 
S6205740 
S6205750 
S6205760 
S6205770 
S6205780 
S6205790 
S6205800 
OR S6205810 
S6205820 
S6205830 
S6205840 
S6205850 
S6205860 
S6205870 
S6205880 
S6205890 
S6205900 
S6205910 
S6205920 
S6205930 
S6205940 
S6205950 
S6205960 
S6205970 
S6205980 
S6205990 
S6206000 
S6206010 
S6206020 
S6206030 
S6206040 
S6206050 
S6206060 
S6206070 
S6206080 
S6206090 
S6206100 
S6206110 
S6206120 
S6206130 
S6206140 
S6206150 
S6206160 
S6206170 
S6206180 
S6206190 
S6206200 
S6206210 
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560 QF=QC0NV(ID0) 

QMAX=QF*XC0RSG (LNDX) 

CQMAX=QMAX 

IF(FLGPH) CQMAX=XCORSG(LNDX) 

«RITE(ICU,9016) <KCDT(I,JLAB).I-1. 13). (KSPECKI. IDO). 1-1.3), QMAX 
. ,(UNITS(N1,JUNIT),N1=1,7) 

9016 FORMAT(8H MAXIMUM, 13A2 ,2H0F, 3A2 , 1H=,G10. 4 ,7A2) 


COMPUTE DEFAULT ISOPLETH VALUES 

NPLETH=0 

DO 580 Nl=l,5 

PLETH(N1+N1-1)=0.0 

PLETH(N1+N1)=0.0 

DPLETH (N 1 ) =DISOF (N 1 ) *QMAX 


C 

C 

C 


DEFAULT ISOPLETHS OF pH. 


IF(.NOT.FLGPH) GO TO 570 
IF (FLOAT (6-Nl) . LT . XCORSG (LNDX) ) 
DPLETH (NPLETH+ 1 ) =FLOAT ( 6-N 1 ) 
570 NPLETH=NPLETH+1 
580 CONTINUE 


GO TO 580 


DISPLAY DEFAULT ISOPLETHS 

590 WRITE(ICU,9017) (TAB 2, INVHF, DPLETH (Nl) 

. , (UNITS (N2.JUNIT) ,N2=1,7) / 

9017 F0RMAT(23H DEFAULT ISOPLETHS ARE: ,3A2,G11.4.9A2/ 
. ,4(21X,3A2,G11.4,9A2/)) 

600 J - 0 


610 J = J+1 

IF (J .GT. 10) GO TO 720 
620 IF (J .GT. 1) GO TO 640 

C'ln URTTF flCU 9018) CURSUP , CLRLNE , INV , OFF , INV , OF on 

,0?8 ENTER .2L.5HEIRST.2A2.17H ISOPLETH VALUE (.2A2. 

*14HSPACE - RETURN , 2A2 , 1 4H FOR DEFAULTS)) 

GO TO 650 
640 Nl = IBLNK 

wLtE (ICU , 90 1 9 ) CURSUP , CLRLNE , CURSUP , CLRLNE , INV , (NFSLS (N2 , J- 1 ) 


*N2=1,3),N1,0FF,INV,0FF 

9019 FORMAT Ua2,7H ENTER ,5A2 ,A1 , 2A2 , 17H 
*14HSPACE - RETURN, 2A2.28HTO TERMINATE 
650 CALL IFNBR(LALPH1,20,IER,ICU) 

IF (lER .EQ. 0) GO TO 660 
WRITE (ICU, 90 10) INV, OFF, 22, 6 
GO TO 620 

660 IF (LALPHl .EQ. IBLNK) GO TO 700 
IF (LALPHl .NE. MINUS 1) GO TO 670 
IF (J .EQ. 1) GO TO 80 


ISOPLETH VALUE (,2A2, 
ISOPLETH INPUT)) 


S6206220 
S6206230 
S6206240 
S6206250 
S6206260 
S6206270 
S6206280 
S6206290 
S6206300 
S6206310 
S6206320 
S6206330 
S6206340 
S6206350 
S6206360 
S6206370 
S6206380 
S6206390 
S6206400 
S6206410 
S6206420 
S6206430 
S6206440 
S6206450 
S6206460 
S6206470 
S6206480 
S6206490 
S6206500 
S6206510 
S6206520 
S6206530 
S6206540 
S6206550 
S6206560 
S6206570 
S6206580 
S6206590 
S6206600 
S6206610 
S6206620 
, S6206630 

S6206640 
S6206650 
S6206660 
S6206670 
S6206680 
S6206690 
S6206700 
S6206710 
S6206720 
S6206730 
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c 

c 

c 

c 


J = J-1 
GO TO 620 
670 CALL C0DE(80) 

READ (LALPHl,*) PLETH(J) 

IF (FLGPH) GO TO 680 

GO T0^610^'^^ .LE. 0.0) GO TO 690 

6lo ™ ^10 

G0^^620^^’^^“ ISOPLETH VALUE IS OUT OF RANGE, 2A2//) 

700 IF (J ,GT. 1) GO TO 720 
C USE DEFAULT VALUES 
DO 710 J=1,NPLETH 
710 PLETH(J) = DPLETH(J) 

GO TO 730 
720 NPLETH = J-1 

(TAB2.PLETH(m).(TOITS(«2,jmiI).H2-l,7).Nl.l. 

9021 jopi (23H ISOPLETHS PLOTTED ARE; .A2.G11.4.7A2/4<21X,A2,G11 .4, 

c 

c LET'S PLOT 

C 

740 CONTINUE 

DIRNL = AIMAG(RBORSG(LNDX)) +180.0 
CALL ORGiNdXO.IYO, DIRNL) 

CLRDSP,BLNKNG,OFF,BKAKO 

9022 FORMAT ( 2 A2 , lOX, 2A2 , 8HPLOTTING, 2A2) 

CALL PLTLU(IPU3) 

CALL SFACTC99. 99,99.99) 

CALL LLEFT 
ITVXX=0 
ITVXN=9999 

CALL SVMB(0.01*FL0AT(IX0-45),0.0I*FLOATaY0-80).1.6,LETRO, 0.0.1) 


c 

c 

c 

c 


DETERMINE THE INDEX OF THE LAYER THAT HAS 

THAT ALTITUDE JUST LOWER THAN THE EFFECTIVE CLOUD HEIGHT, H 

DO 750 1=2, NUM 
IF(H .GT. ALT(I))GO TO 750 
IH = I - 2 
GO TO 760 
750 CONTINUE 

IH = MAXO(LAYTOP(1),LAYTOP(2)) 

CALCULATE THE CLOUD MOVEMENT ALONG THE GROUND 
AS FAR AS THE CLOUD STABILIZATION POINT 

760 X = 0.0 
Y = 0.0 

CALL PLOT(0.01*FLOAT(IX0) ,0. 01*FL0AT(IY0) ,3) 


S6206740 

S6206750 

S6206760 

S6206770 

S6206780 

S6206790 

S6206800 

S6206810 

S6206820 

S6206830 

S6206840 

S6206850 

S6206860 

S6206870 

S6206880 

S6206890 

S6206900 

S6206910 

S6206920 

7A2S6206930 

S6206940 

S6206950 

S6206960 

S6206970 

S6206980 

S6206990 

S6207000 

S6207010 

S6207020 

S6207030 

S6207040 

S6207050 

S6207060 

S6207070 

S6207080 

S6207090 

S6207100 

S6207110 

S6207120 

S6207130 

S6207140 

S6207150 

S6207160 

S6207170 

S6207180 

S6207190 

S6207200 

S6207210 

S6207220 

S6207230 

S6207240 

S6207250 
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RISB0T=0.0 
DO 770 1=1, IH 
X=X+XRF(I) 

Y=Y+YRF(I) 

RISBOT=RISTIM(I) 

IX = INT(0.2631 * X) + IXO 
lY = INT(0.3545 * Y) + lYO 
770 CONTINUE 
780 IHP1=IH+1 

X=X+SPEEDN ( IHP 1 ) * (TAUK-RISTIM ( III) ) *C0S ( (360 . 0-DIRN (IHPl ) ) *D2RAD) 

Y=Y+SPEEDN(IHP1)*(TAUK-RISTIM(IH))*SIN((360.0-DIRN(IHP1))*D2RAD) 

IX=INT (XSCALE*X) +1X0 

IY=INT (YSCALE*Y) +IY0 

ISTABX=IX 

ISTABY=IY 

IFdX.LT. 75. OR.IX. GT.9925.OR.IY.lt. 75. OR.IT.GT. 9925) GO TO 790 
LABEL STABILIZATION POINT WITH A "+" 

CALL SYMB (0. 01*FLOAT(IX) -0. 45, 0.01*FL0AT(IY) -0.8, 1.6, ADD, 0.0,1) 

790 CONTINUE 

PLOT LINE OF MAXIMUM VALUES 

NRNG = 1 
PEN=1 

800 IF(RANGE(NRNG,LNDX).LE.O.O.OR.SIGYBR(NRNG,LNDX).LE.O.O) GO TO 820 
XMAX=XRP (RANGE (NRNG ,LNDX) , BEARNG (NRNG.LNDX) ) 

YMAX=YRP (RANGE (NRNG , LNDX) , BEARNG (NRNG , LNDX) ) 

IX=IFIX(XSCALE*XMAX)+IXO 

IY=IFIX(YSCALE*YMAX)+IYO 

1F(IX.LT.O.OR.IX.GT.9999.0R.IY.LT.O.OR.IY.GT.9999) GO TO 820 
810 CALL PLOT(0.01*FLOAT(IX) ,0.01*FLOAT(IY) ,PEN+2) 

PEN=1-PEN 
820 NRNG=NRNG+1 

IF(NRNG.LT.31) GO TO 800 
C 

C**** LABEL THE POINT OF MAXIMUM WITH AN 
C 

830 XMAX=XRP(REAL(RBORSG(LNDX)) ,AIMAG(RBORSG(LNDX))) 

YMAX=YRP (REAL (RBORSG (LNDX) ) , AIMAG (RBORSG (LNDX) ) ) 

IX=INT (XSCALE*XMAX) +1X0 
IY=INT (YSCALE*YMAX) +IY0 

IF(IX.GE.75.AND.IX.LE.9925.AND.IY.GE.75.AND.IY.LE.9925) 

. CALL SYMB(0.01*FLOAT(IX)-0.45,0.01*FLOAT(IY)-0.8,1.6,AT,0.0,1) 

PD0=1 

840 LETR=IHAT 
C 

c**** find if there are any breaks in ISOPLETHS 
DO 850 1=1,10 
IFISOS(I) =0 
IF (I .GT. 5) GO TO 850 


S6207260 

S6207270 

S6207280 

S6207290 

S6207300 

S6207310 

S6207320 

S6207330 

S6207340 

S6207350 

S6207360 

S6207370 

S6207380 

S6207390 

S6207400 

S6207410 

S6207420 

S6207430 

S6207440 

S6207450 

S6207460 

S6207470 

S6207480 

S6207490 

S6207500 

S6207510 

S6207520 

S6207530 

S6207540 

S6207550 

S6207560 

S6207570 

S6207580 

S6207590 

S6207600 

S6207610 

S6207620 

S6207630 

S6207640 

S6207650 

S6207660 

S6207670 

S6207680 

S6207690 

S6207700 

S6207710 

S6207720 

S6207730 

S6207740 

S6207750 

S6207760 

SG207770 


273 


o n n n n n 


IBREAK(I) = 0 
850 CONTINUE 
NBREAK = 0 
NRNG =0 

860 NRNG = NRNG+1 

IF (NRNG .GT. 30) GO TO 910 

IF (RANGE (NRNG, LNDX) .LE. 0.0) GO TO 860 

XLST = XRP(RANGE(NRNG, LNDX) ,BEARNG(NRNG, LNDX)) 

YLST = YRP (RANGE (NRNG, LNDX) .BEARNG^JRNG, LNDX)) 

870 NRNG = 1 

880 IF (RANGE (NRNG, LNDX) .LE. 0.0) GO TO 900 

XMAX = XRP (RANGE (NRNG, LNDX), BEARNG (NRNG, LNDX)) 

YMAX = YRP (RANGE (NRNG, LNDX) , BEARNG (NRNG, LNDX)) 

XBREAK = SQRT((XMAX-XLST)**2+(YMAX-YLST)**2) 

IF (XBREAK .LT. 2000.0) GO TO 890 
NBREAK = NBREAK+1 

IF (NBREAK. LE. 5. AND. IBREAK (NBREAK) .EQ.O) IBREAK (NBREAK) =NRNG 
890 XLST = XMAX 
YLST = YMAX 
900 NRNG = NRNG+1 
IF (NRNG .LT. 

910 CONTINUE 


31) GO TO 880 


PLOT THE NPLETH ISOPLETHS 

IF (NBREAK .NE. 0) WRITE (ICU.9023) 

9023 FORMAT (/60H WARNING - ISOPLETH PLOT IS BROKEN IN TWO, DUE TO 
* SHEAR//) 

DO 1150 N=l, NPLETH 

NRNG=1 

PEN=3 

CPLETH=PLETH(N) 

CONVERT pH TO CONCENTRATION. 

IF(FLGPH) CPLETH=10.0**(-CPLETH) 

FLGOUT=. FALSE. 

FLGEND=. FALSE. 

FLGLTR=. FALSE. 

FLGDAT=. FALSE. 

LETR=LETR+400B 

920 IF(RANGE(IABS(NRNG), LNDX). LE. 0.0. AND.. NOT. FLGEND) GO TO 1140 
IF (RANGE (lABS (NRNG), LNDX). LE. 0.0. AND. FLGEND) GO TO 930 
QFOC=QF/CPLETH 
V=CORSG (TABS (NRNG) ,LNDX) 

IF(FLGEND) GO TO 940 
IF(NRNG.GT.O) GO TO 940 
FLGEND=.TRUE. 

NRNG=NRNG+1 

IF(NRNG.GT.30) NRNG=-30 
IF(FLGOUT) GO TO 920 
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c 


LABEL DOWNWIND END OF CLOSED ISOPLETHS. 


ANG=(270.0-DIRNL)*D2RAD 

FX=AMAX1 (AMINl (0.01*FL0AT(IX)+1 . 2*COS(ANG) ,98.9) ,0. 
FY=AMAX1 (AMINl (0 . 01*FL0AT(IY) +1 . 2*COS(ANG) ,98. 9) ,0. 
CALL SYMB(FX,FY, 1.0,LETR2,0.0, 1) 

C ALL PLOT ( 0 . 0 1 * FLOAT ( IX) , 0 . 0 1 * FLOAT ( lY) , 3 ) 


1 ) 

1 ) 


GO TO 920 


LOCATION OF MAXIMUM AT DISTANCE= RANGE 

930 SIGYBR(IABS(NRNG) ,LNDX)=S0 
V=0.0 

BEARNG(IABS(NRNG) ,LNDX)=B0 
RANGE (TABS (NRNG) ,LNDX)=R0-1000. 0 
NRNG=-1 
GO TO 950 

940 IF(FLGDAT) GO TO 950 
V0=0.0 

SO=SIGYBR(IABS(NRNG) ,LNDX) 
BO=BEARNG(IABS(NRNG) ,LNDX) 

R0=RANGE ( lABS (NRNG) , LNDX) -1000.0 
FLGDAT=.TRUE. 

950 DR=0. 1* (RANGE (lABS (NRNG) ,LNDX)-R0) 
DB=BEARNG(IABS(NRNG) , LNDX) -BO 
IF(DB.GT. 180. 0) DB=DB-360.0 
IF(DB.LT. -180.0) DB=DB+360.0 
DB=0. 1*DB 
DV=0.1*(V-V0) 

DS=0. 1*(SIGYBR(IABS(NRNG) , LNDX) -SO) 
INTERPOLATE BETWEEN RANGES 
NOPLOT = 0 

IF (NBREAK .EQ. 0) GO TO 1000 
IF (NRNG .GT. 0) GO TO 980 
DO 960 1=1, NBREAK 

IF (lABS(NRNG) .EQ. IBREAK(I)-l) GO TO 970 
960 CONTINUE 
GO TO 1000 
970 NOPLOT = 1 
GO TO 1000 

980 DO 990 1=1, NBREAK 

IF (NRNG .EQ. IBREAK(I)) GO TO 970 

990 CONTINUE 
1000 CONTINUE 

NJPLOT = 0 
NKPLOT = 0 
DO 1100 IR=0,10 
R=R0+DR*FL0AT(IR) 

B=BO+DB*FLOAT (IR) 

QFBOC= (VO+DV*FLOAT (IR) ) *QFOC 
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IF(QFBOC.LT. 1.0) GO TO 1100 
X>IAX=XRPfR,B) 

YMAX=YRP(R,B) 

C 

c CALCULATE CROSSWIND DISTANCE TO ISOPLETH 

NKPLOT = 0 
C 

SIGYB= ( SO+DS*FLOAT ( IR) ) *SQRT (2 . 0*ALOG(QFBOC) ) 

X=XMAX+XRP ( SIGYB , DIRNL+FLOAT (IS IGN ( 90 , NRNG) ) ) 

Y=YMAX+YRP ( SIGYB .DIRNL+FLOAT ( ISIGN (90 , NRNG) ) ) 

IF (ABS(.X-XMAX)-O.l) 1010,1010,1030 
1010 IF (ABS(Y-YMAX)-O. 1) 1020,1020,1030 
1020 IF (NJPLOT .EQ. 0) NKPLOT =1 
NJPLOT = 0 
GO TO 1040 

1030 IF (NJPLOT .EQ. 0) NKPLOT => -1 
NJPLOT = 1 
1040 CONTINUE 

IX=INT(XSCALE*X) +1X0 
IY=INT(YSCALE*Y)+IYO 

IF(IX.LT.O.OR.IX.GT.9999.0R.IY.LT.O.OR.IY.GT.9999) GO TO 1110 

u 

C LABEL ISOPLETHS WITH LETTER: A - J 

C 

IF(.NOT.FLGOUT) GO TO 1050 
FLGOUT=. FALSE. 

GO TO 1120 

1050 IF(FLGLTR) GO TO 1060 
FLGLTR=.TRUE. 

FX=AMAXl(ANINl(0.01*(XSCALE*XMAX+FLOAT(IX0))-0.285 98.9) 0.1) 
FY=AMAX1(AMIN1(0.01*(YSCALE*YMAX+FLOAT(IYO))-0.5 98.9) 0*1) 
CALL SYMB(FX,FY,1.0,LETR2, 0.0,1) 

NDASH=1 

1060 IF (NOPLOT .NE. 0. OR. NKPLOT .NE. 0) PEN = 3 
1070 CALL PLOT(0.01*FLOAT(IX) ,0.01*FLOAT(IY),PEN) 

IF (PEN .EQ. 2) IFISOS(N) = 1 
IFdY.LT. 4900. OR. lY.GT. 5400) GO TO 1080 
ITVXX=MAX0(ITVXX,IX) 

ITVXN=MINO ( ITVXN , IX) 

1080 NDASH=NDASH+ 1 

IF(PEN.LT.3.0R. NOPLOT .NE. 0. OR. NKPLOT .EQ. 1) GO TO 1090 
PEN=2 

GO TO 1070 

IF RANGE IS LESS THAN RXO, PLOT DASHED ISOPLETHS 

1090 IF(R.LT.RXO.AND.MOD(NDASH,3) .EQ.O) PEN=3 
1100 CONTINUE 
GO TO 1130 
1110 PEN=3 

IF(FLGOUT) GO TO 1130 
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c LABEL DOVJmJIND ENDS OF OPEN ISOPLETHS 

C 

c FLGLTR=. FALSE. 

FLGOUT=.TRUE. 

1120 FX=AMAX1(AMIN1(0.01*FLOAT(IX)+0.1,98.9),0,1) 
FY=AMAX1(AMIN1(0.01*FLOAT(IY)+0. 1,98.9) iO. 1) 

CALL SYMB(FX,FY,1.0,LETR2, 0.0,1) 

IF(.NOT.FLGOUT) GO TO 1060 
1130 BO=BEARNG(IABS(NRNG) ,LNDX) 

RO=RANGE(IABS(NRNG) ,LNDX) 

V0=V 

SO=SIGYBR(IABS(NRNG) ,LNDX) 

1140 NRNG=NRNG+1 

IF(NRNG.EQ.O) GO TO 1150 
IF(NRNG.GT.30) NRNG=-30 
GO TO 920 
1150 CONTINUE 
C 

c 

Q 

C ON THE PLOT, CROSS OUT EITHER THE WORD FORECAST OR SOUNDING 

C 

1160 IF(ISNDFO) GO TO 1170 
CALL PLOT(7.07,6.04,3) 

CALL PLOT(11.74,6.04,2) 

GO TO 1180 
C 

1170 CALL PLOT(12.69,6.04,3) 

CALL PLOT(17.60,6.04,2) 


C PRINT OUT FORECAST/SOUNDING TIME ON THE PLOT 

C 

1180 LALPH1=13 

CALL TMNDT (I STIME , I SDAY , I SMON , I SYEAR, I ALPHA) 

CALL SYMB(19.3,5.60,0.80,LALPHA, 0.0,1) 

C 

c PRINT OUT THE TIME OF EXECUTION ON THE PLOT 

C 

CALL TMNDT ( JTIME , JDAY , JMON , JYEAR , lALPHA) 

CALL SYMB (19. 30, 3. 40, 0.80, LALPHA, 0.0,1) 

C IF THE LAUNCH TIME WAS ENTERED, PRINT IT OUT ON THE PLOT 

C ELSE PRINT OUT THE PROGRAM RUN TIME ON THE PLOT. 

C 

CALL TMNDT ( LTIME , LDAY , LMON , LYEAR , lALPHA) 

CALL SYMB (19. 30, 1.20, 0.80, LALPHA, 0.0,1) 

C 

C FOR MODEL 5 OR 6 PLOTS, PRINT NOTATION FOR 

C SUM OF LAYERS OR LOWER LAYER ONLY OR LAYER 1 ONLY 

C OR LAYER 2 ONLY. 

C 

IF (MODEL . EQ . 5 . OR . MODEL . EQ . 6 ) 
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c 

c 

c 


1190 


c 

c 

c 


9024 


C 

C 

C 


CALL SYMB(5.61,8.64,0.8,PS0RL(l,(KS+l)/2), 0.0,1) 

ON THE PLOT, PRINT OUT THE CHARACTERS + AND 0 FOR 
CONTINUE 

CALL SYMB (10. 41, 11. 24, 1.6, AT, 0.0,1) 

CALL SYMB (10. 41, 13. 52, 1.6, ADD, 0.0,1) 

PRINT OUT CALCULATION HEIGHT ON PLOT 

LALPH1=30 
CALL CODE 

WRITE(IALPHA,9024) CALHT 

FORMAT (19HCALCULATION HEIGHT=,F7. 1,4H (M)) 

CALL SYMB(4.81 , 18 . 00 ,0, 8 ,LALPHA,0, 0, 1) 


9025 


C 

C 

C 


9026 


C 

C 

C 
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PRINT OUT LOCATION ON PLOT 

LALPH1=17 
CALL CODE 

WRITE (lALPHA, 9025) LOCATN 
FORMAT (13HPL0TTED AT: ,2A2) 

CALL SYMB (8. 0,22. 0,0. 8, LALPHA, 0.0,1) 

PRINT OUT DATA FILENAME ON THE PLOT 

LALPH1=19 
CALL CODE 

WRITE(IALPHA,9026) FILE 
FORMAT (13H FROM FILE: ,3A2) 

CALL SYMB(8. 0,20. 0,0. 8, LALPHA, 0.0,1) 

PRINT OUT SPECIES NAME ON PLOT 

LALPH1=KSPL(ID0) 

CALL CODE 

WRITEdALPHA, 9009) (KSPECI (I , IDO) , 1=1 , 3) 

CALL SYMB(7. 10,23.80,0. 9, LALPHA.0. 0,1) 

SPECIAL CODING FOR DISPLAY ON TV MONITOR 

ITVX=2770 

ITVY=8610 

Y-COORDINATE OF ALL LAUNCH PADS ON THE LAND MAP IS 
3000 

IF(IY0,GT.30O0) GO TO 1200 
SEA MAP 
ITVY=5240 
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ITVX=ITVXX+125 

CTV 

CTV IS THE STABILIZATION POINT SOUTH OF THE LAUNCH PAD? 

CTV 

IF (ITVXN.lt. 3400) GO TO 1200 
ITVX=ITVXN-750 

CTV 

CTV NOW PLOT SPECIES NAME FOR DISPLAY ON THE TV MONITOR 

CTV 

1200 CALL SYMB(0.01*FLOAT(ITVX) ,0.01*FLOAT(ITVY-190) ,1.25,LALPHA 

. , 0 . 0 , 1 ) 

CTV 

CTV 

CTV 

C 

c PRINT TITLE 

C 

LALPH1=35 
CALL CODE 

WRITE(IALPHA,9027) TITLE 
9027 FORMAT (14A2.7H LAUNCH) 

CALL SYMB(2.01,25.6,0.73,LALPHA, 0.0,1) 

C 

C PRINT OUT CON, DOS, TIME MEAN CON, DEP, ACIDITY. 

C 

LALPH1=KCDTN(JLAB) 

CALL CODE 

WRITE(IALPHA,9009) (KCDT(I , JLAB) , 1=1 , (LALPHl+1) /2) 

. , (UNITS(I,JUN1T) ,1=1,6) 

CTV 

CTV SPECIAL LABEL FOR DISPLAY ON THE TV MONITOR 

CTV 

IF(IYO.GT.3000.0R. ITVXN.lt. 3400) GO TO 1210 
ITVX=ITVXN- 125* (LALPH 1+ 1 ) 

1210 CALL SYMB(0.01*FLOAT(ITVX) ,0. 01*FLOAT(ITVY) , 1 . 25,LALPHA,0. 0, 1) 
CTV 

CTV END SPECIAL CODING FOR DISPLAY ON TV MONITOR 

CTV 

LALPH1=LALPH1+12 

CALL SYMB(8.55+0. 375*FL0AT(36-LALPH1) ,99. 15,0.75,LALPHA,0.0, 1) 
C 

C FOR THE LEGEND ON THE PLOT, PRINT OUT THE CON/DEP/pH VALUES 

C FOR WHICH CONTOURS I7ERE DRA17N 

C 

IXP=900 

IYP=9752 

LETR=IHAT 

DO 1240 I=1,NPLETH 
LETR=LETR+400B 

IF(PLETH(I) .LE. 0.0)G0 TO 1250 
IF(I .NE. 6) GO TO 1220 
IXP=2280 
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IYP=9752 
1220 CONTINUE 
CALL CODE 

WRITE(IALPHA,9002) LETR,PLETH(I) 

LALPH1=13 

C ALL SYMB ( 0 . 0 1 * FLO AT ( IXP ) . 0 . 0 1 * FLO AT ( I YP ) , 0 . 9 5 , L ALPHA , 0 . 0 , 1 ) 

IF (IFISOS(I) ,NE. 0) GO TO 1230 

XLST = .01*FLOAT(IXP)+0.95*FLOAT(LALPHA(D) 

YLST => .01*FLOATUYP) 

CALL SYMB(XLST,YLST,0. 75, NOISOS, 0.0,1) 

1230 IYP=IYP-140 
1240 CONTINUE 
C 

C REMOVE MESSAGE: PLOTTING 

C 

1250 IF(CRT) WRITE(ICU,9009) CR,CURSUP,CLRDSP,BKAKO 
CALL PLOT(99.99,99.99,3) 

1260 WRITE(ICU,9028) INVNDR, INV,OFF,ULINE,OFF,ULINE,OFF 

9028 FORMAT (5 IH DO YOU WISH TO PLOT ISOPLETHS FOR ANOTHER VARIABLE/ 

. 18X,13HOR SPECIES? (, 2A2 , IHV, 2A2 , 7HARIABLE, 2A2 , IH, , 2A2 , IHS, 2A2 , 
*7HPECIES , , 2A2 , IHN , 2A2 , 4HO) :_) 

K=40B 

CALL EXEC(1,ICU+400B,K,-1) 

IF (CRT) WRITE (ICU, 9009) CURSUP,CURSUP,CLRDSP,BKAKO 

ASSIGN 220 TO IGO 

IF (K .EQ. IHS) GO TO 70 

ASSIGN 80 TO IGO 

IF(K.EQ.IHV.OR.K.EQ.IBLNK) GO TO 60 
IF(K.EQ.INJ) GO TO 1270 
WRITE (ICU, 9010) INV,OFF,22,10 
GO TO 1260 
1270 CONTINUE 
C 

G CLEAR TABS BEFORE QUITTING AND PUT PEN IN UPPER RIGHT CORNER. 

C 

IF(CRT) WRITE(ICU,9009) CR, (TAB, CLRTAB, 1=1,5) .CR.BKAKO 
CALL PLOT(99.99,99.99,3) 

C 

C 

C RETURN 

C 

1280 CONTINUE 
RETURN 
C 

c END OF RISOM 

C 

END 
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SUBROUTINE ORGIN(IXO,IYO,DIRNL) 

, , UPDATE: 8213 SOURCE: 02 APR 82 


LOCATION: KSC 


C 

C 

C - 
C - 
C - 
C - 
C — 
CC 


THIS SUBROUTINE GIVES THE APPROPRIATE COORDINATES FOR PLOTTING 
FOR THE COMPLEX AND MAP SELECTED 


BEGINCOMMONAREA , **** 

04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, I VHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , T IMAV , I S IG , I C ALC , CALHT , 

IPLACE , IPRINT , SIGMAR, SIGNER, LSITE , BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NDI SO , NTI SO , FILE ( 3 ) 

, RAINRT , LAMBDA , TIMl , DURAT , NVS , IVERSN , LOCATN (2) 
,IPLLNT(4) ,GAMMAP(30) ,HM(2) ,CISO(10) ,DISO(10) , 
TISO(IO) ,TITLE(14),SIGPP(29),8IGLL(29) ,VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, 

MODEL4 , MODELS , MODELS 
INTEGER RUNNUM , RT , CL , C S 

COMMON /CTRFL/ IFLG, RUNNUM, NUM,NLAYS,NBK,QC,QT, HEAT, ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

SIGZ, ISNDFO, CRT , LAYTOP ( 3 ) , ITDU , KEEP 
, MIXING, MAXDEP, LAYBOT(3) 

,ALTSV,BATCH,CL(14) ,CS(10) , GASSET, lAGAIN, 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80) , 

MINUS 1 ,MINUS9 ,MINS 1 ,MINS9 , 

MODEL4 , MODELS , MODELS ,NNNEST,NNNTRY .LLNEST ,LLNTRY , 
RT(24) ,TPROPC,IDXRT 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR , 

TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 
INVNDR(2) ,ULINE(2) , 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP 
CLRLNE , INSLNE , DELINE , 

IESCAJ(3) ,NULL,IBLNK, 

IPAR(S ) , ICU , lYS J , lYES J , INJ , INOJ , NAMEP (3) 

VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 


S6300000 

SS300010 

SS300020 

-SS300030 

-S6300040 

-SS3000S0 

-SS3000SO 

-SS300070 

-S6300080 

SS300090 

SS300100 

SS300110 

SS300120 

SS300130 

SS300140 

SS3001S0 

SS3001SO 

SS300170 

SS300180 

SS300190 

SS300200 

SS300210 

SS300220 

SS300230 

SS300240 

SS3002S0 

SS3002S0 

SS300270 

SS300280 

SS300290 

SS300300 

S6300310 

SS300320 

S6300330 

SS300340 

SS3003SO 

SS3003S0 

SS300370 

SS300380 

SS300390 

SS300400 

SS300410 

SS300420 

SS300430 

SS300440 

,SS3004S0 

S63004S0 

SS300470 

SS300480 

SS300490 

SS300S00 
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C TIME PARAMETERS 

COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, 
LDAY,LYEAR,ISMON(2) ,JMON(2) ,LMON(2) ,LSDT(2) 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) 

C LAYER PARAMETERS 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , 

SIGYO(29) 

C CALCULATED BOUNDRY DATA (FOR NEX7 LAYERS) 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) 

C CALCULATED NEW LAYER PARAMETERS oujuuo^u 

COMMON /NLYER/ DDIR(32) ,DIRM(32) ,DSPEED(32) ,SIGAPN(32) , SIGEPN(32) , S6300630 
• SPEEDN(32) S6300640 

C CONVERSION FACTORS S6 300650 

COMMON /CNVRT/ QCONV(4) , QPDEPH S6300660 

^ S6300670 

C**********(]Qj^Qjij buffer array FOR COMMON MODIFICATION******************S6300680 
COMMON /EXTRA/ NCOM(l), NTOTAL(l), PLUS(900) S6300690 

C READ/WRITE BUFFER S6300700 

C A R R A Y = 2077 +1 + 1 + 2 * 900 = 3879S6300710 

C***************************-k*-kif***ifk*-k*-k*****i;**ifk**-ki!-kiffci(i,iic-ic.i;.),^^^j^^i,i.f;^^2QQ-]')Q 


S6300510 

S6300520 

S6300530 

S6300540 

S6300550 

S6300560 

S6300570 

S6300580 

S6300590 

S6300600 

S6300610 

S6300620 


C EQUIVALENCE STATEMENTS 

EQUIVALENCE (IPUl , IPAR(3) ) 

, (IPU2,IPAR(4)), (IPU3,IPAR(5)) 
EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) 


C 

c**** 

Cc 


CF 

CF 


END OF COMMON AREA 


DIMENSION RANGE (30, 6) ,BEARNG(30,6) ,SIGYBR(30,6) ,CORSG(30,6) 
. ,RCORSG(6),BCORSG(6),XCORSG(6) 

EQUIVALENCE STATEMENTS 

EQUIVALENCE 

. (PLUS, RANGE) , (PLUS (181) ,BEARNG) , (PLUS (361) , SIGYBR) 

. , (PLUS (541) ,XCORSG) , (PLUS (547 ) ,CORSG) , (PLUS (727) ,RCORSG) 

. ,(PLUS(733),BCORSG) 

OUTPUT FORMAT STATEMENTS 


S6300730 
S6300740 
S6300750 
S6300760 
S6300770 
S6300780 
****S6300790 
S6300800 
S6300810 
S6300820 
S6300830 
S6300840 
S6300850 
S6300860 
S6300870 
S6300880 
S6300890 
S6300900 
S6300910 
S6300920 
S6300930 


9001 FORMAT(2A2,7H MOUNT ,6A2,19H MAP ON PLOTTER LU ,I2,10H FOR SITE 
.A2,A1,7H, ENTER, 2A2,13H SPACE-RETURN, 2 A2 , 1 IH WHEN READY/ 

.50H OR ENTER AN 'A', IF THE ALTERNATE MAP IS DESIRED?/ au-.uu:.ju 

.66H OR AN 'S', IF YOU WISH TO SPECIFY THE LAUNCH SITE MAP LOCATIONS6300940 

S6300950 

9002 FORMAT(2A2/28H ***** PLOTTING IS BASED ON ,6A2,16H MAP COORDINATESS6300960 

.,10H FOR SITE ,A2,A1,5H ****) S6300970 

S6300980 

DIMENSION STATEMENT S6 300990 

S6301000 

INTEGER CRSP S6301010 

DIMENSION IX(12) ,IY(12),LORS(2),IN(2),LORSS(4),NLOC(12) S6301020 
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,DLIMIT(6) 

EQUIVALENCE (IN, INI) 

C 

c DATA STATEMENTS 

C 

C 

C TERMINAL CONTROL SEQUENCES 

C 

E^TA CRSP/6440B/ 

DATA IHA/IHA/.IHS/IHS/ 

DATA LORSS/2KLA,2HND,123B,2HEA/ 

DATA FLOC/2339,1HA,2H39,1HB,2H39,1HC,2H40,1H ,2H41,1H ,2H17,1H / 
C 

c MAP COORDINATES OF LAUNCH SITES 

C 

DATA IX/4200, 4095, 3650, 3518, 3622, 3490, 5450, 5411, 4830, 4825, 8750, 
*8730/ 

DATA IY/1700, 7300, 1123, 6702, 0577, 6150, 2630, 8243, 2465, 8050, 2990, 
*8600/ 

DATA DLIMIT/200. 0,200. 0,200.0, 180.0, 185.0, 180.0/ 

C 

c**** first EXECUTABLE STATEMENT. 

C 

10 LNDSEA=0 

ISITE » 2*LSITE-1 
L0RS(1)=L0RSS(1) 

LORS(2)=LORSS(2) 

C 

C SELECTION OF MAP BASED ON LAUNCH SITE AND WIND DIRECTION 

C 

DIRNL=AMOD (DIRNL ,360.0) 

ICOORD = LSITE 

IF (DIRNL. LE.DLIMIT(ICOORD)) GO TO 20 

LNDSEA=-1 

LORS(l)=LORSS(3) 

LORS(2)=LORSS(4) 

20 IC00RD=2*IC00RD+LNDSEA 

30 WRITE(ICU,9001) CRSP,CLRDSP,INVHF,L0RS,0FF,IPAR(5) ,NLOC(ISITE) , 
*NL0C(ISITE+1) ,ULINE,OFF 
C 

C. WAIT UNTIL CORRECT MAP IS ON PLOTTER. 

C 

INI = NULL 

40 CALL EXEC(1 ,ICU+400B,IN,2) 

IN1=IAND(177400B,IN1)+40B 
IF(INl.EQ.IBLNK) GO TO 80 
IF(INl.EQ.IHA) GO TO 50 
IF (INl.EQ.IHS) GO TO 90 
WRITE (ICU,9003) INV, OFF, 22,8 

9003 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2,6H REC 
*,I2,1H. ,11/) 

GO TO 30 


S6301030 

S6301040 

S6301050 

S6301060 

S6301070 

S6301080 

S530139) 

S63f)110) 

S6301110 

S6301120 

S6301130 

S6301140 

S6301150 

S6301160 

S6301170 

S6301180 

S6301190 

S6301200 

S6301210 

S6301220 

S6301230 

S6301240 

S6301250 

S6301260 

S6301270 

S6301280 

S6301290 

S6301300 

S6301310 

S6301320 

S6301330 

S6301340 

S6301350 

S6301360 

S6301370 

S6301380 

S6301390 

S6301400 

S6301410 

S6301420 

S6301430 

S6301440 

S6301450 

S6301460 

S6301470 

S6301480 

S6301490 

S6301500 

S6301510 

S6301520 

S6301530 

S6301540 
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50 IF (LNDSEA .EQ. 0) GO TO 60 
LNDSEA = 0 
LORS(l) = LORSS(l) 

LORS(2) = LORSS(2) 

GO TO 70 
60 LNDSEA = -1 

LORS(l) = LORSSC3) 

L0RS(2) = L0RSS(4) 

70 ICOORD = LSITE 

ICOORD = 2*IC00RD+LNDSEA 
80 CONTINUE 


S6301550 

S6301560 

S6301570 

S6301580 

S6301590 

S6301600 

S6301610 

S6301620 

S6301630 

S6301640 

S6301650 


WRITE (ICU, 9002) CURSUP, DELINE, ULINE, LORS , OFF, NLOC(ISITE) ,NLOC(ISITS6301660 

S6301670 

S6301680 

SET THE COORDINATES BASED ON THE INDEX I S6301690 

, V S6301700 

IXO = IX(ICOORD) S6301710 

lYO = lY(ICOORD) S6301720 

GO TO 120 S6301730 

90 CONTINUE S6301740 

WRITE (ICU, 9004) CURSUP, DELINE S6301750 

9004 FORMAT (2A2/68H ON A SCALE OF 0 TO 9999 UNITS IN BOTH X AND Y DIRES6301760 
*CTI0NS, ENTER THE/66H LAUNCH LOCATION (0,0 IS THE LOWER LEFT CORNES6301 770 


*R OF PLOT BED), X,Y?:) 

CALL IFNBR(IFRMT,20,IER,ICU) 

IF (lER .EQ. 0) GO TO 100 
WRITE (ICU, 9003) INV,OFF,22,9 
GO TO 90 

100 CALL CODE (20) 

READ (IFRMT,*) SN,WE 
IF (SN .EQ. MINSl) GO TO 10 
IF (SN .NE. MINS9) GO TO 110 
lERROR(l) = 1 
NNNEST = 1 
CALL REEDM 
no IXO = SN 
lYO = WE 

WRITE (ICU, 9005) CURSUP,DELINE,INV,OFF 
9005 FORMAT (2A2/26H *** PLOTTING IS BASED ON ,2A2,14HUSER SPECIFIED, 
*2A2,19H LAUNCH COORDINATES) 

120 CONTINUE 

RETURN TO THE CALLING PROGRAM 
RETURN 


END OF ORGIN 


END 


S6301780 

S6301790 

S6301800 

S6301810 

S6301820 

S6301830 

S6301840 

S6301850 

S6301860 

S6301870 

S6301880 

S6301890 

S6301900 

S6301910 

S6301920 

S6301930 

S6301940 

S6301950 

S6301960 

S6301970 

S6301980 

S6301990 

S6302000 

S6302010 

S6302020 

S6302030 
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9001 


SUBROUTINE TMNDT (ITIME, IDAY , IMON , lYEAR, lALPHA) 
UPDATE: 8213 SOURCE: 3 SEP 81 LOCATION: 

DIMENSION lALPHA(l) ,IM0N(2) ,M0N(12) 

DATA MON/ 2HJA » 2HFE , 2HMA , 2HAP , 2HMA , 2HJU , 2HJU , 2HAU 

2HDE/ 

’ DATA IHY , IHL, IIHMO , IIHSO/ IHY , IHL , 2H-0 , 2H/0/ 
F0RMAT(I4,1H-,I2,1H/,I2,1H/ ,12) 


KSC 

,2HSE,2HOC,2HNO 


IM=1 

10 IF(IM0N(1).EQ.M0N(IM)) GO TO 20 


IM=IM+1 


IF(IM.LT.13) GO TO 10 
STOP 7777 

20 IF(IM.NE.3) GO TO 30 
IF (IMON ( 2 ) . EQ . IHY) IM=5 
GO TO 40 

30 IF(IM.NE.6) GO TO 40 
IF(IMON(2).EQ.IHL) IM=7 
40 IY=MOD(IYEAR,100) 


CALL CODE 

WRITE ( lALPHA, 900 1 ) ITIME , IM , IDAY , lY 

IF(IALPHA(1)!lT. 30000B) IALPHA(1)-IALPHA(1)+10000B 
IF(IALPHA(3).LT. IIHMO) IALPHA(3)»IIHM0 
IF(IALPHA(5).LT.30000B) IALPHA(5)=IALPHA(5)+10000B 
IF ( lALPHA ( 6 ) . LT . I IHSO ) lALPHA ( 6 ) * IIHSO 


RETURN 

END 


-S6400000 

S6400010 

S6400020 

S6400030 

-S6400040 

S6400050 

S6400060 

S6400070 

S6400080 

S6400090 

S6400100 

S6400110 

S6400120 

S6400130 

S6400140 

S6400150 

S6400160 

S6400170 

S6400180 

S6400190 

S6400200 

S6400210 

S6400220 

S6400230 

S6400240 

S6400250 

S6400260 

S6400270 

S6400280 

S6400290 

S6400300 
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SUBROUTINE RMCLM 


8213 SOURCE 


02 APR 82 LOCATION 


ORGANIZATION: H. E. CRAMER CO., INC. 

WORK FOR: DR. J. B. STEPHENS (ES84) 

PROGRAM CODE: RMCLM 

PROGRAM DESCRIPTION: ONE OF THE MODULES FOR ROCKET EXHAUST 

EFFLUENT DIFFUSION ANALYSIS (MULTI-LAYER) 

INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS 

OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS, PLOTS 


, , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S6500010 

= = S6500020 

! ! ! = * = - — : — S650D030 

C;;'.’ ::: S6500040 

C:;: ORGANIZATION: H. E. CRAMER CO. , INC. i!; S6500060 

C::: WORK FOR: DR. J. B. STEPHENS (ES84) j’’ S6500080 

C::: PROGRAM CODE: RMCLM ’’’ J6500090 

C;:; S6500100 

C... PROGRAM DESCRIPTION: ONE OF THE MODULES FOR ROCKET EXHAUST ::: S6500120 

effluent diffusion analysis (MULTI-LAYER)::: S6500130 

C::: INPUT: USER SPECIFIED MET SOUNDING AND USER SPECIFIED OPTIONS i:! leSOOlSO 

C:;: OUTPUT: PRINTED LISTING OF DATA FILE, ANALYSIS. PLOTS i;! S6500170 

C: . ; • • 

Q = = = = S6500200 

C *********************************************************************^^^J°210 

c * CENTERLINE PLOTTING PROGRAM ~ A PROGRAM OF THE REED *56500240 

C * SERIES OF PROGRAMS 

*********************************************************************gg^°°27o 

C**** 04/02/82 ®EGIN COMMON AREA ****86500290 

C math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI.G,CP,MAXLEV.GAMMAI,GAMMAC 

C input OPTIONS qfiSnn33n 

REAL LAMBDA 

INTEGER FILE, GOOD. TITLE 

COMMON /INPUT/ IRUN, NUMRUN, MODEL, IVHICL, NORMAL, TPROP, S6500360 

• FSHAPE,GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S6500370 

• XRY,XRZ,XLRY,TIMAV,ISIG,ICALC.CALHT, S6500380 

IPLACE, IPRINT, SIGMAR, SIGMER.LSITE.BOTLAY, S6500390 

ZRK, DECAY, GOOD. NCISO.NDISO.NTISO, FILED) S6500400 

jRAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S6500410 

,IPLLNT(4),GAM^L4P(30),HM(2),CISO(10),DISO(10), S6500420 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , S6500430 

• FS(20).MDLNAM(12).DBAR(20) S6500440 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S6500450 

LOGICAL ISNDFO. CRT, MAXDEP, BATCH, GASSET, GRVSET, S6500460 

MODEL4.MODEL5,MODEL6 qAsnnZ7n 

INTEGER RUNNUM.RT.CL.CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S6500490 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK, S6500500 
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S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP S 6 5 00 5 1 0 

, MIXING, MAXDEP.LAYBOT (3) S6500520 

, ALTSV, BATCH, CL(14) ,CS(10) , GAS SET, I AGAIN, S6500530 

ICHAR(12),IDXCL,IDXCS,IERR0R(5),IFRMT(80), S6500540 

MINUSl ,MINUS9 ,MINS1 ,MINS9 , S6500550 

M0DEL4, MODELS, M0DEL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S6500560 
RT(24) ,TPR0PC,IDXRT S6500570 

TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S6500580 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S6500590 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , S6500600 

CLRLNE,INSLNE, DELINE S6500610 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S6500620 

INVNDR(2) ,ULINE(2) , S6500630 

TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , S6500640 


S6500650 

S6500660 

S6500670 

S6500680 

S6500690 

S6500700 

S6500710 

S6500720 

S6500730 

S6500740 

S6500750 

S6500760 

S6500770 

S6500780 

S6500790 

S6500800 

S6500810 


CLRLNE , INSLNE , DELINE , 

IESCAJ(3) ,NULL,IBLNK, 

IPAR ( 5 ) , ICU , lYS J , lYES J , INJ , INOJ , NAMEP (3) 

VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 

C TIME PARAMETERS 

COMMON /TIME/ JTIME, JDAY,JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, 
LDAY,LYEAR,ISM0N(2) , JMON(2) ,LMON(2) ,LSDT(2) 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30)',TEMP(30) ,PRESS(30) , 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) 

C LAYER PARAMETERS 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , 

SIGYO(29) 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) 

COMMON /BLAYR/ DIRB(6) , SPEEDB(6) ,TEMPB(6) 

C CALCULATED NEW LAYER PARAMETERS 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) , SIGAPN(32) , SIGEPN(32) , S6500820 
SPEEDN(32) S6500830 

C CONVERSION FACTORS S6500840 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S6500850 

C S6500860 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S6500870 

COMMON /EXTRA/ NCOM(l) , NTOTAL(l), PLUS(900) S6500880 

C READ /WRITE BUFFER S6 500890 

C A R R A Y - 2077 + 1 + 1 + 2 * 900 = 3879S6500900 

C***********************************************************************S6500910 
C_ S6500920 

S6500930 
S6500940 
S6500950 
S6500960 
S6500970 
****S6500980 
S6500990 
S6501000 
S6501010 
S6501020 


C**** 

Cc 


EQUIVALENCE STATEMENTS 

EQUIVALENCE ( IPU 1 , IP AR ( 3 ) ) 

, (IPU2 , IPAR(4) ) , (IPU3 , IPAR(5) ) 
EQUIVALENCE (MAXDEP,GRVSET) , (IFRMT(l) ,IFRMT1) 

END OF COMMON AREA 


DIMENSION RANGE(30,6) ,BEARNG(30,6) ,SIGYBR(30,6) ,CORSG(30,6) 
. ,RCORSG(6) ,BCORSG(6) ,XCORSG(6) 
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c 

c 

c 


c 

c 

c 


EQUIVALENCE STATEMENTS 

EQUIVALENCE 

. (PLUS, RANGE) , (PLUS (181) ,BEARNG) , (PLUS (361) , SIGYBR) 

. , (PLUS(541) .XCORSG) , (PLUS(547) ,CORSG) , (PLUS(727) ,RCORSG) 

. ,(PLUS(733),BCORSG) 

TYPE AND DIMENSION STATEMENTS 

LOGICAL IGRAF , FLGSPC (4 ) , TO 

INTEGER CRLF,YORNO,CR,BGLINE,DFLT,YUNITS,YUNIT(3,4) ,PTITL(12,3) 

. ,PDO,BKAKO,ZIP,BKARO 

DIMENSION LLABEL(17) ,LPLLNT(3,4) ,IP(5) ,IN(2) ,LSPECI(11,4) 

. ,LPAREN(2) ,IALPHA(50) ,YORNO(16) , JSPECI(3,4) ,L1 (3) ,IBUFR(71) 

. ,IREG(2) ,ZIP(5) 

EQUIVALENCE (IN, INI) , (LI (2) ,L3) , (REG,IREG,IA) , (IREG(2) ,IB) 

DATA STATEMENTS 

DATA LPLLNT/0B,2HHC,2HL ,OB,2HCO,2H2 , OB , 2HCO , OB , 2HAL 
,2H20,2H3 / 

DATA LPAREN,BKARO,CRLF,CR,BKAKO,ZIP 
/2H( ,2H ),20137B,6412B,15B,137B,5*0/ 

DATA PTITL 

/2HCO,2HNC,2HEN,2HTR,2HAT,2HIO,2HN ,2HAN,2HD ,2HDO,2HSA,2HGE 
, 2HWA , 2HSH , 2HOU , 2HT , 2HDE , 2HPO , 2HSI , 2HTI , 2HON , 3* IH 
, 2HGR, 2HAV, 2HIT , 2HAT , 2HIO, 2HNA, 2HL . 2HDE , 2HPO, 2HSI , 2HTI , 2HON / 
DATA JSPECI 
/2H ,2H H,2HCL 

,2H ,2H C,2H02 

,2H ,2H ,2HCO 

,2H A,2HL2,2H03/ 

DATA YUNIT/2,4,0 
, 2 , 0,0 
. 2 , 0,0 
,1.3,5/ 

DATA LSPECI 

/15446B,62104B,110B,15446B,62100B,2HCL,15446B,62100B,OB,15446B 

.62100B 

,15446B,62104B,103B,15446B,62100B,117B,15446B,62104B,62B,15446B 

.62100B 

,15446B,62104B,103B,15446B,62100B,117B,15446B,62100B,0B,15446B 

.62100B 

,15446B,62104B, lOlB, 15446B, 62100B,2HL2 , 15446B,62100B, 2H03 , 15446B 
,62100 b/ 

DATA YORNO 

/15446B,62106B,131B,15446B,62102B,2HES,15446B,62100B,2H 0,2HR 
,15446B,62104B,116B,15446B,62100B,117B/ 

DATA ICOMMA/26000B/ 

DATA IH2,IHM,IHP/1H2,1HM,1HP/ 

FIRST EXECUTABLE STATEMENT 
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S6501250 
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S6501310 

S6501320 

S6501330 

S6501340 

S6501350 
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S6501380 
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S650140Q 

S6501410 
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c 

c SELECT VARIABLES AND POLLUTANTS TO BE PLOTTED. 

C 

IF (CRT) GO TO 40 
K=0 

DO 30 1=1,5 
IF(I.EQ.5) GO TO 20 
DO 10 J=l,4 

LSPECI(3*I-1,J) = NULL 
LSPECI(3*I-2,J) = NULL 
10 CONTINUE 

IF(I.EQ.4) K=1 
20 YORNO(3*I+K-2) = NULL 
YORNO(3*I+K-l) = NULL 
30 CONTINUE 

40 WRITE (ICU, 9001) SETTAB.CR.BKAKO 
9001 FORMAT(59X,3A2) 

IVARP=0 
50 NSPECI=0 
NWDS=0 
JM112=0 

IF (MODEL. EQ. 6) IPLLNT(1)=4 
DO 70 J=l,4 

IF(IPLLNT(J) .LE.O) GO TO 80 

IF(M0DEL.GT.4.AND.(IPLLNT(J).EQ.2.0R.IPLLNT(J).EQ.3)) GO TO 70 
NWDS=NWDS+12 
NSPECI=NSPECI+1 
FLGSPC ( IPLLNT ( J) ) = . TRUE . 

DO 60 1=1,11 

IALPHA(I+JM112)=LSPECI(I,IPLLNT(J)) 

60 CONTINUE 

I ALPHA ( NWD S ) = I C OMMA 
JM112=NWDS 
70 CONTINUE 

80 IALPHA(NWDS)=LPAREN(2) 

NO PROMPT FOR ONLY ONE SPECIES 
IF(NSPECI.LT.2) GO TO 110 
INVERSE VIDEO FOR DEFAULT 
DO 90 J=2,8,3 

IALPHA(J+12*IVARP)=IOR(IALPHA(J+12*IVARP) ,2B) 

90 CONTINUE 
100 WRITE(ICU,9002) 

WRITE (ICU, 9005) LPAREN(l) , (lALPHA(I) ,1=1 ,NWDS) ,BKARO 

9002 FORMAT ( 3 9H PLOT MAXIMUM CENTERLINE VALUES FOR: _) 

LI = NULL 

CALL EXEC(1,ICU+400B,L1,3) 

9003 FORMAT(5Al) 

L2=IAND(L1,377B) 
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L1=IAND(L1,177400B) 

C 

C ERASE PROMPT 

C 

WRITE ( I CU , 9005 ) CR , CURSUP , CLRDSP , BKAKO 
IF(L1.NE.20000B) GO TO 120 
C 

C DEFAULT 

C 

110 IDO=IPLLNT(IVARP+l) 

IF(IDO.GT.O) GO TO 210 
IDO=IPLLNT(l) 

IVARP=0 
GO TO 210 

120 IF(L1.NE.44000B.OR. .NOT.FLGSPC(D) GO TO 130 
C 

C HCL SELECTED 

C 

IDO=l 
GO TO 210 

130 IF(L1.NE,40400B.0R. .N0T.FLGSPC(4)) GO TO 140 
C 

c AL203 SELECTED 

C 

IDO=4 
GO TO 210 

140 IF(L1.EQ.41400B.AND. (FLGSPC(3) .OR.FLGSPC(2))) GO TO 160 
C 

C BAD ENTRY PROCESSING 
C 

150 WRITE (ICU,9004) INV,OFF,21,2 

9004 FORMAT (2A2,38H *** REEDM ERROR 001, DATA INPUT ERROR, 2A2.6H REG 
*,I2,1H. ,11/) 

9005 FORMAT (5 2A2) 

GO TO 100 

C 

C C02 AND CO 

C 

160 IF(L2.NE.62B.OR. .NOT.FLGSPC(2)) GO TO 180 
C 

C C02 SELECTED 

C 

170 ID0=2 

GO TO 210 

180 IF(L2.NE.40B.OR. .N0T.FLGSPC(3)) GO TO 200 
C 

c CO SELECTED 

C 

190 ID0=3 

GO TO 210 

200 IF(L2.NE. 117B) GO TO' 150 

IF((L3.EQ.IBLNK.OR.L3.EQ.0B) .AND.FLGSPC(3)) GO TO 190 
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210 


220 


9006 


IF(L3.EQ.IH2.AND.FLGSPC(2)) GO TO 170 

S6502590 

GO TO 150 

S6502600 

S6502610 

INITIALIZE THE PLOTTER 

S6502620 

S6502630 

CALL PLTLU(IPU2) 

S6502640 

CALL SFACT (33. 0,24.0) 

S6502650 

CALL LLEFT 

S6502660 

PDO=3 

S6502670 

IF(MODEL.LT.5) GO TO 220 

S6502680 

PDO=l 

S6502690 

IF(LAYTOP(2) .GT.O) PDO=8-MODEL 

S6502700 

QF=QCONV(IDO) 

S6502710 

YUNITS=YUNIT (MODEL-3 , IDO) 

S6502720 

IF(MODEL.LT.6) GO TO 240 

S6502730 

WRITE(ICU,9006) INVNDR , INV , OFF , ULINE , OFF , BKARO 

S6502740 


230 


,,2A2,1HP,2A2,14HARTICLES/M**2),A2) 

K = IHM 

CALL EXEC(1,ICU+400B,K,-1) 

WRITE ( ICU , 9 00 5 ) CURSUP , DEL INE , BKAKO 

IF(K.EQ.IBLNK.OR.K.EQ.IHM) GO TO 240 

IF^.EQ.IHP) GO TO 230 

WRITE (ICU, 9004) INV,0FF,21,3 

GO TO 220 

CONTINUE 

YUNITS=6 

PLOT THE CENTERLINE DOSAGE AND CONCENTRATION VALUES 


DISPLAY PLOTTING 

WRITE (ICU, 9007) BLNKNG,OFF 
CALL LABEL(PDO, IDO, YUNITS, MODEL) 

FORMAT ( 1 OX , 2 A2 , 8HPL0TTING , 3 A2 ) 

CALL CPLOT(PDO, IDO, YUNITS, MODEL) 

WRITE (ICU, 9005) CR, CURSUP , CLRDSP , BKAKO 

WRITE(ICU,9008) (PTITL(I, MODEL-3) , 1=1 , 12) , (JSPECI(I, IDO) 

.1=1.3) 

F0RMAT(20H MAXIMUM CENTERLINE ,12A2,16H PLOTTED FOR: ,5A2) 

IVARP=MOD ( IVARP+ 1 , NSPECI) 

] PUT THE PEN IN THE UPPER RIGHT CORNER AND CLEAR THE TAB 

WRITE ( ICU , 9 00 5 ) CR . TAB , CLRT AB , CR . BKAKO 
250 WRITE hcU, 9009) YORNO,BKARO 

9009 FORMAT (6 2H DO YOU WISH TO PLOT CENTERLINE PROFILES FOR ANOTHER 
.CIES?(,16A2,1H) ,A2) 

K = IBLNK 

CALL EXEC(1,ICU+400B,K,-1) 

WRITE ( ICU , 9 005 ) CURSUP , CURSUP , CLRDSP , BKAKO 


240 

9007 


9008 
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IF(K.EQ.IBLNK.OR.K.EQ.IYSJ) GO TO 260 
IF(K.EQ.INJ) GO TO 270 
WRITE (ICU,9004) INV,OFF,21,4 
GO TO 250 
260 NNNTRY=5 
GO TO 280 
270 NNNTRY = 6 
280 CONTINUE 
CALL URITE 

RETURN 

RETURN 
C 

C END OF RNCLM 

C 

END 
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SUBROUTINE CPLOT ( PDO , IDO , YUNITS , IP) 

. , UPDATE: 8213 SOURCE: 02 APR 82 


LOCATION: KSC 


C 

c 

c 


THIS SUBROUTINE PLOTS THE CENTERLINE CURVES 




cc 

c**** BEGIN COMMON AREA 

04/02/82 

math PARAMETERS AND CONSTANTS 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC 

C INPUT OPTIONS 

REAL LAMBDA 

INTEGER FILE, GOOD, TITLE 

COMMON /INPUT/ IRUN,NUMRUN, MODEL, IVHICL, NORMAL, TPROP, 

I SHAPE , GAMMAX , GAMMAY , GAMMAZ , ALPHA , BETA , 

XRY , XRZ , XLRY , TIMAV , IS IG , ICALC , CALHT , 

IPLACE , IPRINT , SIGMAR, SIGMER, LSITE , BOTLAY , 

ZRK , DECAY , GOOD , NCISO , NDI SO , NTISO , FILE ( 3 ) 

, RAINRT , LAMBDA , TIM 1 , DURAT , NVS , I VERSN , LOCATN ( 2 ) 

, IPLLNT(4) ,GAMMAP(30) ,HM(’2) ,CIS0(10) ,DIS0(10) , 
TISO(IO) ,TITLE(14),SIGPP(29),SIGLL(29),VS(20) , 
FS(20) ,MDLNAM(12) ,DBAR(20) 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES 

LOGICAL ISNDFO , CRT ,MAXDEP , BATCH , GASSET , GRVSET , 

MODEL4 , MODELS , MODEL6 
INTEGER RUNNUM,RT,CL,CS 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, 

DPDZ , TAUK , SURDEN , ZRL , IBOT , ITOP , SIGXNK , SIGYNK , 

S IGZ , I SNDFO , CRT , LAYTOP ( 3 ) , ITDU , KEEP 
.MIXING, MAXDEP,LAYBOT(3) 

, ALTSV , BATCH , CL ( 14 ) , CS ( 10) , GASSET , lAGAIN , 

ICHAR(12) ,IDXCL,IDXCS,IERROR(5) ,IFRMT(80), 

MINUS 1 , MINUS9 , MINS 1 .MINS9 , 

MODEL4 , MODELS , MODEL6 , NNNEST , NNNTRY , LLNEST , LLNTRY , 
RT(24) , TPROP C,IDXRT 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. 

INTEGER ALTSET , OFF , BLNKNG , INV , ULINE , INVNDR, 
i TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT , CLRDSP , 

. CLRLNE , INSLNE , DELINE 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , 

. INVNDR(2) ,ULINE(2), 

. TAB , TAB2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT, CLRDSP , 

. CLRLNE, INSLNE, DELINE, 

. IESCAJ(3) ,NULL,IBLNK, 

I P AR ( 5 ) , I CU , I Y S J , lYES J , INJ , INO J , NAMEP ( 3 ) 

C VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 

C TIME PARAMETERS 


S6600000 
S6600010 
S6600020 
-S6600030 
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COMMON /TIME/ JTIME, JDAY, JYEAR,ISTIME,ISDAY,ISYEAR,LTIME, S6600510 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S6600520 

C SOUND ING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S6600530 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S6600540 

RH(30),PTEMP(30),SIGEP(30),SIGAP(30) S6600550 

C LAYER PARAMETERS S6600560 

COMMON /LAYER/ DXX,DYY,DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) , S6600570 

SIGYO(29) S6600580 

C CALCULATED FOUNDRY DATA (FOR NEW LAYERS) S6600590 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) S6600600 

C CALCULATED NEW LAYER PARAMETERS S6600610 

COMMON /NLYER/ DDIR(32) ,DIRN(32) .DSPEED (32) , SIGAPN(32) , SIGEPN (32) , S6600620 
SPEEDN(32) S6600630 

C CONVERSION FACTORS S6600640 

COMMON /CNVRT/ QCONV(4) ,QPDEPH S6600650 

C S6600660 


C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S6600670 
COMMON /EXTRA/ NCOM(l) , NTOTAL(l) , PLUS(900) S6600680 

C READ/TOITE BUFFER S6600690 

C A R R A Y = 2077 +1+ 1 +2* 900 = 3879S6600700 


C 

C- 


C 

cc 


EQUIVALENCE STATEMENTS 

EQUIVALENCE (IPUl , IPAR(3) ) 

, (IPU2 , IPAR(4) ) , (IPU3 , IPAR(5) ) 
EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) , IFRMTl) 

END OF COMMON AREA 


C 

C 

C 

C 


DIMENSION RANGE (30,6), BEARNG (30,6), SIGYBR (30 , 6 ) , CORSG (30 , 6 ) 
. ,RCORSG(6) ,BCORSG(6) ,XCORSG(6) 

EQUIVALENCE STATEMENTS 

EQUIVALENCE 

, (PLUS, RANGE) , (PLUS (181) , BEARNG) , (PLUS (361) , SIGYBR) 

. , (PLUS (541) ,XCORSG) , (PLUS (547) , CORSG) , (PLUS (727) ,RCORSG) 

. .(PLUS (733), BCORSG) 

DIMENSION STATEMENT 
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C** THE VARIABLE NAME "PLUS" WAS CHANGED NOV 9, 1979 BECAUSE OF A CONFLIS6600920 


C** ARISING WITH THE TABLED COMMON DEVICE. .. J. S,H. 

C 

DIMENSION YDIST(6) 

INTEGER ADD ( 2 ) , PEN , 0 ( 2 ) , PDO , PDOP , YUNITS , GASORA , lALPHA (12) 
. ,LALPHA(2) 

EQUIVALENCE (LALPHA(2) , lALPHA) , (LALPHA.LALPHl) 

DATA FXDIST/1.0/ 

, ADD/1, lH+/,D2RAD/0. 01745329/, 0/1, IHO/ 

DATA YDTST/1 1,04, 12. 24, 14. 84, 0.0, 15. 44, 14. 24/ 
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c 

c 

c 

c 

c 


STATEMENT FUNCTION FOR PH 

FIY(L)=16 . 4-2 . 0*AMAX1 (0 . 0 , AMINl (7 . 0 ,-ALOGT(CORSG(NRNG,L) ) ) ) 


S6601030 

S6601040 

S6601050 

S6601060 


CALCULATE AND PLOT INTEGER SCALING FACTOR 


[DOSAGE OR MODELS 5 S6 60 1070 

S6601080 


GASORA=3*(IDO/4) 

IF(YUNITS.EQ.6) GAS0RA=0 
YDIST1=16.34 
IF(IP.GT.4. AND. IDO.NE. 1) 

EX=ALOGT (AMAXl (XCORSG (GASORA+ 1 ) , XCORSG (GASORA+3) ) *QCONV (IDO) ) 
IF(IP.EQ.4) EX=ALOGT(XCORSG(GASORA+2)*QCONV(IDO)) 

IEXP=EX 

IF(EX.LT.O.O) IEXP=IEXP-1 

LALPH1=2 

IEXP=-IEXP 

CALL CODE 

WRITE (lALPHA, 9001) lEXP 
9001 FORMAT (12) 

IF (IP. LT. 5) CALL SYMB(0. 8 , YDISTl ,0. 2 .LALPHA, 90. 0, 1) 
PFAC1=20.0*QCONV(IDO)*10.0**(IEXP-1) 

PFAC=PFAC1 

GO TO (90,50,10),PDO 
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S6601180 

S6601190 

S6601200 
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S6601220 

S6601230 

S6601240 

S6601250 

S6601260 


PLOT SYMBOLS 'O' FOR UPPER LAYER OR TIME MEAN CONCENTRATION 
10 NRNG=1 

IF(IP.GT.4) GO TO 20 

SCALE FACTOR FOR TIME MEAN CONCENTRATION IS THE SAME 
AS FOR CONCENTRATION 

EX= ALOGT (XCORSG (GASORA+ 1 ) *QCONV ( IDO) ) 

IEXP=EX 

IF(EX.LT.O.O) IEXP=IEXP-1 
IEXP=-IEXP 

PFAC=20.0*QCONV(IDO)*10.0**(IEXP-1) 

20 IF (RANGE (NRNG, PDO+GASORA) .LE. 0.0) GO TO 30 
X=0 . 00 1*RANGE (NRNG , PDO+GASORA) +2 . 37 
Y=PFAC*CORSG (NRNG , PDO+GASORA) +2.4 
C 

c PH PLOTTED? 

C 

IF (IP . EQ . 5 . AND . IDO . EQ . 1 ) Y=FIY (PDO) 

IF(X.LT.2.50.OR.X.GT.32.5.OR.Y.LT.2.5.OR.Y.GT.22.5) GO TO 30 
CALL SYMB(X,Y,0.2,0,0.0,1) 

30 NRNG=NRNG+1 

IF(NRNG.LT.31) GO TO 20 
C 

c PLOT SYMBOLS '+' FOR LOWER LAYER OR DOSAGE 

C 

40 PDO=2 
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IF(IP.EQ.A) PFAC=PFAC1 
PD0P=2 
50 NRNG=1 

60 IF(RANGE(NRNG,PD0+GAS0RA) .LE.0.0) GO TO 70 
X=0 . 00 1 *RANGE ( NRNG , PDO+GASORA) +2.37 
Y=PFAC*CORSG (NRNG, PDO+GASORA) +2.4 
C 

C PH PLOTTED? 

C 

IF(IP.EQ.5.AND.ID0.EQ. 1) Y=FIY(PDO) 

IF(X.LT.2.5.0R.X.GT.32.5.0R.Y.LT.2.5.0R.Y.GT.22.5) GO TO 70 
CALL SYMB(X,Y, 0.2, ADD, 0.0,1) 

70 NRNG=NRNG+1 

IF(NRNG.LT.31) GO TO 60 
C 

C PLOT LINE FOR COMBINED LAYERS OR CONCENTRATION 

C 

80 PDO=l 
PDOP=l 
90 NRNG=1 
PEN=3 

IF(IP.GT.4) GO TO 100 
C 

C CALCULATE SCALE FACTOR FOR CONCENTRATION 

C 

EX=ALOGT (XCORSG (PDO+GASORA) *QCONV( IDO)) 

IEXP=EX 

IF(EX.LT.O.O) IEXP=IEXP-1 

IEXP=-IEXP 

CALL CODE 

WRITE (I ALPHA, 9001) lEXP 

PFAC=20 . 0*QC0NV (IDO) *10 . 0** (IEXP-1 ) 

100 IF(YDIST(YUNITS) .GT.0.0) 

. CALL SYMB(0.8,YDIST(YUNITS),0.2,LALPHA,90.0,1) 

110 IF(RANGE(NRNG, PDO+GASORA). LE. 0.0) GO TO 130 
X=0.001*RANGE(NRNG,PDO+GASORA)+2.5 
Y=PFAC*CORSG (NRNG, PDO+GASORA) +2. 5 
C 

C PH PLOTTED? 

C 

IF(IP.EQ.5.AND.IDO.EQ. 1) Y=FIY(PD0)+0, 1 

IF(X.LT.2.5.0R.X.GT.32.5.0R.Y.LT.2.5.0R.Y.GT.22.5) GO TO 130 
120 CALL PLOT (X,Y, PEN) 

9002 F0RMAT(1X3A2,I3,6I7,2G12.4/12G11.4/12G11.4) 

IF(PEN.LT.3) GO TO 130 
PEN=2 
GO TO 120 
130 NRNG=NRNG+1 

IF(NRNG.LT.31) GO TO 110 
140 CALL PLOT(33. 0,24. 0,3) 

C 

C RETURN TO RCONC 
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c S6602070 

RETURN S6602080 

S6602090 

END OF CPLOT S6602100 

S6602110 

end S6602120 


c-------------- S6700000 

C S6700010 

C S6700020 

C S6700030 

C-------------- S6700040 

SUBROUTINE LABEL(PDO,IDO,YUNITS,IP) S6700050 

. , UPDATE: 8213 SOURCE: 02 APR 82 LOCATION: KSC S6700060 

C S6700070 

C S6700080 

C - S6700090 

C - THIS SUBROUTINE LABELS THE CONCENTRATION AND DOSAGE CENTERLINE S6700100 
C - PLOTS S6700110 

C - S6700120 

C S6700130 

CC S6700140 

C**** BEGIN COMMON AREA ****36700150 

C 04/02/82 S6700160 

C MATH PARAMETERS AND CONSTANTS S6700170 

COMMON /MATH/ PI,G,CP,MAXLEV,GAMMAI,GAMMAC S6700180 

C INPUT OPTIONS S6700190 

REAL LAMBDA S6 700200 

INTEGER FILE, GOOD, TITLE S6 7 002 10 

COMMON /INPUT/ IRUN,NUMRUN,MODEL, IVHICL.’NORMAL.TPROP, S6 7002 20 

ISHAPE,GAMMAX,GAMMAY,GAMMAZ, ALPHA, BETA, S6700230 

XRY,XRZ,XLRY,TIMAV,ISIG,ICALC,CALHT, S6700240 

IPLACE,IPRINT,SIGMAR,SIGMER,LSITE,BOTLAY, S6700250 

ZRK, DECAY, GOOD, NCISO,NDISO,NTISO,FILE(3) S6700260 

, RAINRT, LAMBDA, TIM1,DURAT,NVS,IVERSN,L0CATN(2) S6700270 

,IPLLNT(4),GAMMAP(30),HM(2),CISO(10),DISO{10), S6700280 

TISO(IO) ,TITLE(14) ,SIGPP(29) ,SIGLL(29) ,VS(20) , S6700290 

FS(20),MDLNAM(12),DBAR(20) S6700300 

C COUNTERS, FLAGS, GENERAL AND INDEX VARIABLES S6700310 

LOGICAL ISNDFO, CRT, MAXDEP, BATCH, GASSET, GRVSET, S6700320 

MODEL4,MODEL5,MODEL6 S6700330 

INTEGER RUNNUM,RT,CL,CS S6700340 

COMMON /CTRFL/ IFLG,RUNNUM,NUM,NLAYS,NBK,QC,QT,HEAT,ZM,H, S6700350 

DPDZ,TAUK,SURDEN,ZRL,IBOT,ITOP,SIGXNK,SIGYNK, S6700360 

. SIGZ, ISNDFO, CRT, LAYTOP(3),ITDU, KEEP S6700370 

, MIXING, MAXDEP, LAYBOT (3) S6700380 

, ALTSV, BATCH, CL ( 14 ),CS( 10), GASSET, lAGAIN, S6700390 

ICHAR(12),IDXCL,IDXCS,IERROR(5),IFRMT(80), S6700400 

MINUS1,MINUS9,MINS1,MINS9, S6700410 

MODEL4, MODELS, MODEL6,NNNEST,NNNTRY,LLNEST,LLNTRY, S6700420 
RT(24) ,TPROPC,IDXRT S6700430 

C TERMINAL CONTROL CHARACTERS AND LOGICAL UNIT NUMBERS. S6 700440 

INTEGER ALTSET,OFF,BLNKNG,INV,ULINE,INVNDR, S6700450 

TAB,TAB2,SETTAB,CLRTAB,CURSUP,CURSDN,CURLFT,CLRDSP, S6700460 

CLRLNE,INSLNE, DELINE S6700470 

COMMON /CNTRL/ ALTSET(2) ,OFF(2) ,BLNKNG(2) ,INV(2) ,INVHF(2) , S6700480 

INVNDR(2),ULINE(2), S6700490 

. TAB , TAB 2 , SETTAB , CLRTAB , CURSUP , CURSDN , CURLFT ,CLRDSP,S6700500 


298 



CLRLNE.INSLNE, DELINE, S6700510 

! lESCAJO) ,NULL,IBLNK, S6700520 

IPAR(5) ,ICU,IYSJ,IYESJ,INJ,IN0J,NAMEP(3) S6700530 

C 1 VEHICLE PARAMETERS 

COMMON /VCLPR/ VPAR(17) 

C TIME PARAMETERS 

COMMON /TIME/ JTIME, JDAY, JYEAR.ISTIME.ISDAY.ISYEAR.LTIME, S6700570 

LDAY,LYEAR,ISMON(2),JMON(2),LMON(2),LSDT(2) S6700580 

C SOUNDING/FORCAST METEOROLOGICAL DATA (INITIAL LEVELS) S6700590 

COMMON /FRCST/ ALT(30) ,DIR(30) ,SPEED(30) ,TEMP(30) ,PRESS(30) , S6700600 

RH(30) ,PTEMP(30) ,SIGEP(30) ,SIGAP(30) S6700610 

C LAYER PARAMETERS ^ 

COMMON /LAYER/ DXX,DYY.DX(29) ,DY(29) ,Q(29) ,RISTIM(29) ,SIGXO(29) . S6700630 

. SIGYO(29) S6700640 

C CALCULATED BOUNDRY DATA (FOR NEW LAYERS) S6700650 

COMMON /BLAYR/ DIRB(6) ,SPEEDB(6) ,TEMPB(6) 

C CALCULATED NEW LAYER PARAMETERS S6700670 

COMMON /NLYER/ DDIR(32) ,DIRN(32) ,DSPEED(32) ,SIGAPN(32) ,SIGEPN(32) .S6700680 

SPEEDN(32) S6700690 

C CONVERSION FACTORS S6700700 

COMMON /CNVRT/ QCONV(4) .QPDEPH 

^ S6700720 

C**********COMMON BUFFER ARRAY FOR COMMON MODIFICATION******************S6700730 
COMMON /EXTRA/ NCOM(l), NTOTAL(I) , PLUS(900) 

C READ/WRITE BUFFER ^ ,„,„S6700750 

R R A Y = 2077 + 1 + 1 + 2 * 900 ~ 3879S6700760 

r***********************************************************************S^^°°^^^ 

^ ce.ir\man 


C 

Q**** 

CC 

C 


EQUIVALENCE STATEMENTS 

EQUIVALENCE (IPUl ,IPAR(3)) 

, (IPU2 , IPAR(4) ) , (IPU3 , IPAR(5) ) 
EQUIVALENCE (MAXDEP.GRVSET) , (IFRMT(l) .IFRMTl) 

END OF COMMON AREA 


DIMENSION RANGE(30,6) ,BEARNG(30,6) ,SIGYBR(30,6) ,CORSG(30,6) 
,RCORSG(6) ,BCORSG(6) ,XCORSG(6) 

EQUIVALENCE STATEMENTS 

EQUIVALENCE 

(PLUS, RANGE) , (PLUS(181) ,BEARNG) , (PLUS(361) .SIGYBR) 

, (PLUsb^l) .XCORSG) , (PLUS (547) ,C0RSG) , (PLUS (7 27) .RCORSG) 

, , (PLUS (733), BCORSG) 

COMPLEX CYLABl (7) ,CYLAB2(7) ,CYLAB3(7) ,CYLAB4(7) ,CYLAB5(7) 

, ,CYLAB6(7) 

INTEGER PD0,YLAB(32,6),YUNITS,PLGND(15,7),PTITL(13,3) 
DIMENSION IALPHA(18),LPLLNT(6,4) ,LALPHA(2) 

EQUIVALENCE (LALPHA(2) , lALPHA) , (LALPHA.LALPHl) 

. . (YLAB (2,1), CYLAB 1 ) , (YLAB (2,2), CYLAB2) , (YLAB (2,3), CYLAB3) 

, , (YLAB (2,4), CYLAB4 ) , (YLAB (2 , 5 ) , CYLAB5 ) , (YLAB (2,6), CYLAB6) 
DATA LPLLNT/2H F,2HOR,2H H,2HCL,2H ,8 
,2H F,2HOR,2H C,2H02,2H ,8 
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,2H F.2HOR.2H C.2H0 ,2H ,8 

,2H F,2HOR,2H A,2HL2,2H03, 10/ 

DATA PLGND 

/22,4*2H ,2H C,2HON,2HCE,2HNT,2HRA,2HTI,2HON,3*20040B 

,15,4*2H+ ,2H D,2HOS,2HAG,2HE ,6*20040B 

,28,4*2H0 ,2H ,2H ,2H M,2HIN,2H. ,2HAV.2HE , 2HCO, 2HNC, 20040B 

,19,4*2H ,2H D,2HEP,2HOS,2HIT,2HIO,2HN ,4*20040B 

,16,4*2H ,2H A,2HCI,2HDI,2HTY,6*20040B 

,20,4*2H0 ,2H U.2HPP,2HER.2H L,2HAY.2HER,4*20040B 
,20,4*2H+ ,2H L,2HOW,2HER,2H L,2HAY,2HER,4*2H / 

DATA PTITL 

/24,2HCO,2HNC,2HEN,2HTR,2HAT,2HIO,2HN ,2HAN,2HD ,2HDO,2HSA,2HGE 
,18, 2HWA , 2HSH , 2H0U , 2HT , 2HDE , 2HPO , 2HSI , 2HTI , 2H0N , 3*20040B 
, 24 , 2HGR, 2HAV , 2HIT , 2HAT , 2HI0 , 2HNA, 2HL , 2HDE , 2HP0 , 2HSI , 2HTI , 2H0N / 
DATA CYLABl /8HC0NCENTR.8HATI0N X ,8H10 [MG/M 
,8H**3] - ,8H DOSAGE ,8HX 10 [MG,8H-SEC/M**/ 

DATA CYLAB2 /8H CO,8HNCENTRAT,8HION X 10 
,8H [PPM] -,8H DOSAGE ,8HX 10 [PP,8HM-SEC] / 

DATA CYLAB3 /8H ,8H WAS,8HHOUT DEP 

,8H0SITI0N ,8HX 10 [MG,8H/M**2] ,8H / 

DATA CYLAB4 /8H ,8H ,8H WASHOUT 

,8H DEPOSIT, 8HI0N [PH],8H ,8H / 

DATA CYLAB5 /8H ,8H GRAVIT,8HATIONAL 

,8HDEP0SITI,8H0N X 10 ,8H[MG/M**2,8H] ’ / 

DATA CYLAB6 /8H GRA,8HVITATION,8HAL DEPOS 
,8HITION X ,8H10 [PART,8HICLES/M*,8H*2] / 

DATA YLAB (1,1), YLAB (30,1), YLAB(3 1,1), YLAB (32,1) 

,YLAB(1,2) , YLAB (30, 2) ,YLAB01,2) ,YLAB02,2) 

, YLAB (1,3) ,YLAB(30,3),YLAB01,3),YLAB(32,3) 
,YLAB(1,4),YLAB(30,4) ,YLAB(31,4) ,YLAB(32,4) 
,YLAB(1,5).YLAB(30,5),YLAB(31,5),YLAB(32,5) 
,YLAB(1,6),YLAB(30,6),YLAB(31,6),YLAB(32,6) 


58, 

2H3], 

41, 

68 

54, 

2H . 

47. 

68 

46, 

2H , 

58, 

0 

40, 

2H , 

0, 

0 

49. 

2H , 

64. 

0 

53, 

2H , 

58, 

0/ 


c 

CF OUTPUT FORMAT STATEMENTS 

CF 

9001 FORMAT (I 2) 

9002 FORMAT (F5.0) 

9003 FORMAT (F4.1) 

9004 F0RMAT(I4,2A2,I3,1X,A2,A1,1X,I4) 

9005 FORMAT (55A2) 

9006 FORMAT (F4.1) 


FIRST EXECUTABLE STATEMENT 


GASORA=3* (IDO/4) 
IPM3=IP-3 
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LALPH1=4 
CALL CODE 

WRITE (lALPHA, 9005) LOCATN 
CALL SYMB (20. 5, 2 1.0, 0.2, LALPHA, 0.0, 1) 

PRINT OUT THE DATA FILENAME ON THE PLOT 

LALPH1=6 
CALL CODE 

WRITE(IALPHA,9005) FILE 
CALL SYMB (20. 5, 20. 5, 0.2, LALPHA, 0.0,1) 

CROSS OUT SOUND INC /FORECAST AS APPROPRIATE 

IF(ISNDFO)GO TO 90 
CALL PLOT(18.6,22.6,3) 

CALL PLOT(20.2,22.6,2) 

GO TO 100 

90 CALL PLOT(16.6,22.6,3) 

CALL PLOT08.4,22.6,2) 

100 CONTINUE 

PLOT LEGENDS 

CALL PLOT(25.5,22.5,3) 

CALL PLOT(26.8,22.5,2) 

CALL PLOT(26.8,22.5,3) 

IF(IP.GT.4) GO TO 110 

CALL SYMB(25.5,22.5,0.20,PLGND(1,1) ,0.0,1) 
CALL SYMB(25.5,22.0,0.20,PLGND(1,2),0.0,1) 
CALL SYMB(25.5,21.5,0.2,PLGND(1,3),0.0,1) 
TMIN=TIMAV/60.0 
LALPH1=4 
CALL CODE 

WRITE (I ALPHA, 900 3) TMIN 
CALL SYMB (27. 2, 2 1.5, 0.2, LALPHA, 0.0,1) 

GO TO 150 

110 IF(IDO.EQ.l) GO TO 120 

CALL SYMB (25. 5, 22. 5,0. 20, PLGND (1,4) ,0.0,1) 

GO TO 130 

120 CALL SYMB(25.5,22.5,0.20,PLGND(1,5) ,0.0,1) 

130 IF(LAYTOP(2).LE.O) GO TO 150 
IF(IP.EQ.6) GO TO 140 

CALL SYMB(25.5,22.0,0.20,PLGND(1 ,6) ,0.0,1) 

140 CALL SYMB(25.5,21.5,0.20,PLGND(1,7) ,0.0,1) 

C 

C RETURN TO RMCLM 

C 

150 RETURN 
C 

C END OF LABEL 

END 
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CALL PLOT(2.5,22.5,3) 

70 CALL SYMB(1.0,7.7,0.2,YLAB(1,YUNITS),90.0,1) 

IZ=1 

C 

C PRINT OUT CLOUD HEIGHT, TIME OF RISE, TOP OF LAYER 

C BOTTOM OF LAYER, AND HEIGHT OF CALCULATION ON THE PLOT 

C 

80 IF(CALHT.GT.ALT(LAYT0P(1)+1)) IZ=2 

IF(MODEL4 .AND. IDO.EQ.4 .AND. LAYTOP(IZ+l) .GT.O) IZ = IZ + 

LALPH1=5 

CALL CODE 

WRITE (I ALPHA, 9002) H 

CALL SYMB(12.3,22.5,0.20,LALPHA,0.0,1) 

CALL CODE 

WRITE (lALPHA, 9002) TAUK 

CALL SYMB( 12. 3, 22. 0,0. 20, LALPHA, 0.0,1) 

CALL CODE 

WRITE ( lALPHA ,9002) ALT (LAYTOP ( IZ ) + 1 ) 

CALL SYMB(12. 3, 21. 5, 0.20, LALPHA, 0.0,1) 

CALL CODE 

WRITE(IALPHA,9002) ALT(LAYBOT(IZ) ) 

IF(IALPHA(2) .LT. 20060B) IALPHA(2)=20060B 
CALL SYMB( 12. 3, 21. 0,0. 20, LALPHA, 0.0,1) 

CALL CODE 

WRITE(IALPHA,9002) CALHT 

IF(IALPHA(2) .LT.20060B) IALPHA(2)=20060B 

CALL SYMB( 12. 3, 20. 5, 0.20, LALPHA, 0.0,1) 

C 

C PRINT OUT THE SOUNDING TIME ON THE PLOT 

C 

LALPH1=20 
CALL CODE 

WRITE ( lALPHA , 9004 ) ISTIME , LSDT , ISDAY , ISMON , ISYEAR 
IF ( lALPHA (D.LT.30000B) lALPHA ( 1 ) =IALPHA ( 1 ) + lOOOOB 
CALL SYMB(20. 5, 22. 5, 0.20, LALPHA, 0.0,1) 

C 

C PRINT OUT THE PREDICTION TIME ON THE PLOT 

C 

CALL CODE 

WRITE ( lALPHA ,9004) JTIME , LSDT , JDAY , JMON, JYEAR 
IF ( lALPHA ( 1 ) . LT . 30000B) IALPHA( 1 ) =IALPHA( 1 ) +10000B 
CALL SYMB(20. 5, 22. 0,0. 20, LALPHA, 0.0,1) 

PRINT OUT THE LAUNCH TIME ON THE PLOT 

CALL CODE 

WRITE ( lALPHA , 9004 ) LTIME , LSDT , LDAY , LMON .LYEAR 
IF ( lALPHA ( 1 ) . LT . 30000B ) lALPHA ( 1 ) =IALPHA ( 1 ) + 1 OOOOB 
CALL SYMB(20. 5, 21. 5, 0.20, LALPHA, 0.0,1) 

C 

C PRINT OUT THE RUN LOCATION ON THE PLOT 

C 
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c 

c GET PLOT TITLE 

C 

LALPH1=PTITL ( 1 , IPM3) 

I12=LALPHl/2+l 

LALPH 1 =LALPH 1 +LPLLNT ( 6 , IDO ) 

I2=LALPHl/2+l 

DO 20 1=2,12 

IF(I.GT.I12) GO TO 10 

LALPHA (I)=PTITL(I,IPM3) 

GO TO 20 

10 LALPHA(I)=LPLLNT(I-I12,IDO) 

20 CONTINUE 

CALL SYMB (9. 7, 23. 4, 0.5, LALPHA, 0.0,1) 
FI=0.0 

IF(IP.NE.5.0R.ID0.NE.l) GO TO 30 
C 

c SET UP pH SCALE 

C 

FI=0.0 
FY=16.4 
IY=15 
PI=0.5 
GO TO 40 
C 

C SET UP LINEAR SCALE 

C 

30 FI=10.0 
FY=22.4 
IY=21 
DI=-0.5 
C 

C PLOT Y-UNITS 

40 DO 50 1=1, lY 
LALPH1=4 
CALL CODE 

WRITE(IALPHA,9006) FI 
CALL SYMB(1. 2, FY, 0.2, LALPHA, 0.0,1) 
FI=FI+DI 
FY=FY-1.0 
50 CONTINUE 
C 

C PLOT Y-AXIS 

C 

FY=3.5 

CALL PLOT(2.5,2.5,3) 

DO 60 I=1,IY-1 
CALL PLOT(2.5,FY,2) 

CALL PLOT(2.2,FY,2) 

CALL PLOT(2.5,FY,2) 

FY=FY+1.0 
60 CONTINUE 
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